Menu

Extraction de données dans divers fichiers xls d'un même dossier

Signaler
-
cs_Le Pivert
Messages postés
6432
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
12 décembre 2019
 -
Bonjour,

Je suis en train de faire une macro sous Excel 2016. Je suis novice et rencontre quelques difficultés pour "finaliser" le projet….

Voici le code à l'instant T :

Sub ESSAI1()

Dim wkA As Workbook, wkB As Workbook
Dim chemin As String, fichier As String
Dim j As Long

Application.ScreenUpdating = False 'gagner en temps d'execution
Set wkA = ThisWorkbook 'le dossier qui va recevoir les donn?es
chemin = "C:\Users\T0159962\Desktop\Direction Technique\Devis Ingenierie\" 'adresse commun pour les deux dossiers sources
'******************************* Copier donnees Classeur A
fichier = "TDMSFR1268093-00 - FPV - SPGE - FT287 rev 00" 'Nom du classeur 1
Workbooks.Open chemin & fichier & ".xlsm" 'ouvrir classeur1
Set wkB = ActiveWorkbook
j = 2
wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

wkB.Close True

j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row

'******************************* Copier donnees Classeur B
fichier = "TDMSFR1266422-03- ATL2 - FPV ISTS Iguane"
Workbooks.Open chemin & fichier & ".xlsm"
Set wkB = ActiveWorkbook
wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

wkB.Close True

Application.ScreenUpdating = True

End Sub

Voici les problèmes rencontrés :
-Au lieu de mettre les informations dans la ligne en dessous de la première pour le fichier A, cela me met les informations dans la ligne au dessus…. Cela modifie donc le nom de mes colonnes… au lieu d'ajouter les informations à la suite.

-Il faudrait que cela me copie la valeur de la cellule source et non la formule qui y est insérée.

-La mise en forme du fichier source est conservée lors du copiage, cependant j'aimerais que ce soit la mise en forme du fichier de synthèse qui soit appliquée.

-Et pour finir, mon code sera parfait lorsque j'aurais inséré une boucle qui dit "ouvrir un à un les fichier du répertoire XXX, pour effectuer le copié collé" .. Pour l'instant la macro ne traite que 2 fichiers…

MERCI par avance pour votre aide précieuse!
Ju

Configuration: Windows / Edge 18.17763
Afficher la suite
Réponse 1
Messages postés
6432
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
12 décembre 2019
 423
Bonjour, 

j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row


te donne la dernière ligne renseignée. Il faut donc ajouter une ligne pour avoir la 1ère ligne vide.
Comme ceci: 

j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row + 1
Signaler

Merci pour le retour,
Après modification, la macro a une erreur, elle m'indique 2 fois les résultats du second fichier l'un en dessous de l'autre et n'affiche plus le résultat du fichier A :

Sub ESSAI1()

Dim wkA As Workbook, wkB As Workbook
Dim chemin As String, fichier As String
Dim j As Long

Application.ScreenUpdating = False 'gagner en temps d'execution
Set wkA = ThisWorkbook 'le dossier qui va recevoir les donn?es
chemin = "C:\Users\T0159962\Desktop\Direction Technique\Devis Ingenierie\" 'adresse commun pour les deux dossiers sources
'******************************* Copier donnees Classeur A
fichier = "TDMSFR1268093-00 - FPV - SPGE - FT287 rev 00" 'Nom du classeur 1
Workbooks.Open chemin & fichier & ".xlsm" 'ouvrir classeur1
Set wkB = ActiveWorkbook

j = 2
wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

wkB.Close True

j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row + 1

'******************************* Copier donnees Classeur B
fichier = "TDMSFR1266422-03- ATL2 - FPV ISTS Iguane"
Workbooks.Open chemin & fichier & ".xlsm"
Set wkB = ActiveWorkbook
wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

wkB.Close True

Application.ScreenUpdating = True

End Sub

Voyez vous le problème ?
Signaler
cs_Le Pivert
Messages postés
6432
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
12 décembre 2019
 423
regarde cela pour parcourir un répertoire:

https://vbaforexcel.wordpress.com/2013/09/06/lister-les-fichiers-et-sous-dossiers-dun-dossier/

elle m'indique 2 fois les résultats du second fichier l'un en dessous de l'autre :

c'est normal, tu as mis 2 fois la même chose: 

wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)


Voilà
Signaler
cs_Le Pivert
Messages postés
6432
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
12 décembre 2019
 423
Tu peux t'inspirer de ce post:

https://www.commentcamarche.net/forum/affich-36313734-copier-la-meme-cellule-de-plusieurs-classeur-dans-un-autre#1

@+ Le Pivert
Réponse 5

Bonjour,

J'ai abouti quant à mon besoin, j'ai seulement un problème qui persiste...

J'avais essayé "Application.DisplayAlerts = False/True" pour empêcher les pop-ups de s'ouvrir mais cela ne fonctionne pas…

En fait c'est une fenêtre d'alerte indiquant que le fichier est à la dernière version existante, qui s'ouvre à l'ouverture de chaque fichier source… Or il y a 50 fichiers source, cela demande de rester derrière le PC et cliquer sur "OK" toutes les 5 secondes. Très gênant.

Avez-vous une solution ?

Merci
Ju
Signaler
cs_Le Pivert
Messages postés
6432
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
12 décembre 2019
 423
L'as-tu mis juste avant d'ouvrir chaque fichier comme cela? 

For Each fichier In dossier.Files
    If fichier = ThisWorkbook.Path & "\" & ThisWorkbook.Name Then 'chemin classeur reception
    Else
   Application.DisplayAlerts = False
 Set wb = Workbooks.Open(fichier)


Si le message persiste il faudrait voir dans les options d'Excel.

Ce n'est pas une version limitée?

@+
Répondre Posez votre question