Boucle extraction de données vers un fichier de synthèse
Bonjour à toutes et tous,
Je vous explique mon problème :
J'ai un classeur excel de synthèse "principal" qui récapitule les données extraites des classeurs "source".
La feuille "recap" est la feuille du classeur "principal" qui récapitule les données extraites. Le nom initial de cette feuille est "Récupération des données".
Les classeurs "source" sont tous situés dans le même dossier "repertoire". Ils sont identiques et portent des noms "fichier" de 1 à 100.
Exemple : 3.xlsx
Les données à extraire dans les classeurs "source" sont situées dans la même feuille "VBA".
Je cherche à faire une boucle qui extrait les données de chaque fichier pour les insérer dans mon classeur de synthèse "principal". J'ai écrit ce code, mais sans succès, pouvez-vous m'aider s'il vous plaît ?
Sub recuperation()
'Déclarer les variables
Dim principal As Workbook 'fichier récapitulatif
Dim recup As Worksheet 'feuille récapitulative
Dim repertoire As String 'dossier source
Dim source As Workbook 'fichier source
Dim fichier As String 'nom du fichier source
Dim VBA As Worksheet 'feuille source
'Désactiver le rafraîchissement de l'écran avant la macro
Application.ScreenUpdating = False
'Ouvrir la feuille source du fichier source
Set principal = ThisWorkbook
repertoire = "C:\Users\Julie\Documents\Entreprise\Outil évaluation" 'Modification nécessaire en cas de changement d'ordinateur
ChDir repertoire
fichier = Dir("*.xls")
Set recup = principal.Worksheets("Récupération des données")
Set VBA = source.Worksheets("VBA")
Do While fichier <> ""
If fichier <> principal.Name Then
Workbooks.Open fichier
On Error GoTo suivant
With Sheets("Récupération des données")
On Error GoTo 0
On Error Resume Next
.Range("B6").Value = VBA.Range("B6")
.Range("C6").Value = VBA.Range("C6")
.Range("C7").Value = VBA.Range("C7")
End With
ActiveWorkbook.Close False
End If
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""VBA"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
fichier = Dir
Loop
End SubMerci d'avance
Julie
bonjour,
proposition de correction de ton code, pour ce qui est de la sauvegarde des données dans recup, ton code réécrit les données de chaque fichier en B6,C6 et C7. je doute que ce soit le but, j'ai proposé une correction : écriture des donnes trouvées en B6,B7 et C7 dans les colonnes B,C et D de recup.
Sub recuperation()
'Déclarer les variables
Dim principal As Workbook 'fichier récapitulatif
Dim recup As Worksheet 'feuille récapitulative
Dim repertoire As String 'dossier source
Dim source As Workbook 'fichier source
Dim fichier As String 'nom du fichier source
Dim VBA As Worksheet 'feuille source
'Désactiver le rafraîchissement de l'écran avant la macro
Application.ScreenUpdating = False
'Ouvrir la feuille source du fichier source
Set principal = ThisWorkbook
repertoire = "C:\Users\Julie\Documents\Entreprise\Outil évaluation" 'Modification nécessaire en cas de changement d'ordinateur
Set recup = principal.Worksheets("récupération des données")
Set dlr = recup.Cells(Rows.Count, "B").End(xlUp).Row ' dernière ligne utilisée sur recup
fichier = Dir(repertoire & "\*.xlsx")
Do While fichier <> ""
If fichier <> principal.Name Then
Workbooks.Open fichier
Set source = ActiveWorkbook
Set VBA = source.Worksheets("VBA")
On Error GoTo suivant
With recup
On Error GoTo 0
dlr = dlr + 1 'on ajoute une ligne sur recup
.Range("B" & dlr).Value = VBA.Range("B6")
.Range("C" & dlr).Value = VBA.Range("C6")
.Range("D" & dlr).Value = VBA.Range("C7")
End With
source.Close False
End If
suite:
On Error GoTo 0
fichier = Dir()
Loop
Exit Sub
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""VBA"" dans le fichier " & fichier, vbExclamation: source.Close False: Resume suite
MsgBox "une erreur " & Err.Number & " est survenue"
End SubBonjour
Désolée pour le retard de réponse, je viens de me replonger dans la macro seulement maintenant.
Je te remercie pour ton aide !
Je pense que le problème vient d'ailleurs car je souhaitais que la macro permette de :
- ouvrir chaque fichier du répertoire un à un
- copier les données
- coller les données dans un fichier de synthèse
- fermer le fichier ouvert
- ouvrir le suivant
Mais cela ne fonctionne pas... Je vais lâcher l'affaire, mais merci encore en tout cas
Pour info, j'ai réécris la macro de la sorte histoire de l'alléger, mais sans succès.
Sub recuperation()
'Déclarer les variables
Dim target_wb As Workbook 'fichier récapitulatif
Dim target_ws As Worksheet 'feuille récapitulative
Dim source_path As String 'dossier source
Dim source_wb As Workbook 'fichier source
Dim source_ws As Worksheet 'feuille source
'Désactiver le rafraîchissement de l'écran avant la macro
Application.ScreenUpdating = False
'Ouvrir la feuille source du fichier source
source_path = "C:\Users\Julie\Documents\Outil évaluation\" 'Modification nécessaire en cas de changement d'ordinateur
ChDir source_path
source_wb = Dir("*.xlsx", vbNormal)
Set target_wb = ThisWorkbook
Set target_ws = target_wb.Worksheets("Récupération des données")
Do While source_wb <> ""
Workbooks.Open source_wb
Set source_wb = ActiveWorkbook
Set source_ws = source_wb.Worksheets("VBA")
With target_ws
.Range("B" & dlr).Value = source_ws.Range("B6")
.Range("C" & dlr).Value = source_ws.Range("C6")
.Range("D" & dlr).Value = source_ws.Range("C7")
End With
ActiveWorkbook.Close False
Loop
End SubBonjour,
il y avait quelques erreurs dans ma macro. je pense les avoir corrigées.
Sub recuperation()
'Déclarer les variables
Dim principal As Workbook 'fichier récapitulatif
Dim recup As Worksheet 'feuille récapitulative
Dim repertoire As String 'dossier source
Dim source As Workbook 'fichier source
Dim fichier As String 'nom du fichier source
Dim VBA As Worksheet 'feuille source
'Désactiver le rafraîchissement de l'écran avant la macro
Application.ScreenUpdating = False
'Ouvrir la feuille source du fichier source
Set principal = ThisWorkbook
repertoire = "C:\Users\Julie\Documents\Entreprise\Outil évaluation" 'Modification nécessaire en cas de changement d'ordinateur
Set recup = principal.Worksheets("récupération des données")
dlr = recup.Cells(Rows.Count, "B").End(xlUp).Row ' dernière ligne utilisée sur recup
fichier = Dir(repertoire & "\*.xlsx")
Do While fichier <> ""
If fichier <> principal.Name Then
Workbooks.Open repertoire & fichier
Set source = ActiveWorkbook
On Error GoTo suivant
Set VBA = source.Worksheets("VBA")
With recup
On Error GoTo 0
dlr = dlr + 1 'on ajoute une ligne sur recup
.Range("B" & dlr).Value = VBA.Range("B6")
.Range("C" & dlr).Value = VBA.Range("C6")
.Range("D" & dlr).Value = VBA.Range("C7")
End With
source.Close False
End If
suite:
On Error GoTo 0
fichier = Dir()
Loop
Exit Sub
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""VBA"" dans le fichier " & fichier, vbExclamation: source.Close False: Resume suite
MsgBox "une erreur " & Err.Number & " est survenue"
End SubIl y a toujours un bug, je ne sais pas si je me trompe mais il n'y aurait pas une confusion entre le nom du workbook ("fichier") et le workbook (source) dans la macro ?
re-bonjour,
cette macro fonctionne chez moi. Ne disposant pas de tes fichiers j'ai dû me créer mon propre environnement pour tester.
répertoire, nom des classeurs, nom des feuilles dans chaque classeur. (autant de choses qui pourraient être différentes chez toi)
quel message d'erreur as-tu ? sur quelle instruction ?
J'ai une erreur sur la "dlr", ça bugue à ce moment là.
Ce qui m'étonne c'est qu'on a juste déclaré "fichier" mais on n'a pas déclaré son lien avec "source".
jvstn a écrit :J'ai une erreur sur la "dlr", ça bugue à ce moment là.
quel message d'erreur stp ?
Ce qui m'étonne c'est qu'on a juste déclaré "fichier" mais on n'a pas déclaré son lien avec "source".
le fichier est ouvert via l'instruction workbook.open. une fois le fichier ouvert il devient actif et le lien entre source et le fichier se fait par l'instruction set source=activeworkbook
h2so4 a écrit :jvstn a écrit :J'ai une erreur sur la "dlr", ça bugue à ce moment là.
Il s'agit de l'erreur 1004 !
Super merci pour cette information car je ne comprenais pas du tout
le fichier est ouvert via l'instruction
workbook.open. une fois le fichier ouvert il devient actif et le lien entre source et le fichier se fait par l'instructionset source=activeworkbook
Je t'ai mis en PJ un exemple du fichier source et du fichier récapitulatif, sachant qu'il y a :
- plusieurs onglets dans chaque fichier (j'ai juste gardé ceux qui nous servaient, "VBA" pour "source" et "Récupération des données" pour "principal")
- d'autres fichiers sources ayant pour nom 1.xlsx; 2.xlsx ..... jusqu'à n.xlsx dans le même dossier source "repertoire"
Merci encore
bonjour,
dans l'instruction
dlr = recup.Cells(rows.count,2).End(xlUp).Row XlUp = X+L+U+P et non X+1+U+P
Re-bonjour,
J'avance bien avec tes conseils, merci !
Mais ça me copie-colle la 1ère ligne de mon fichier 1, la 2ème ligne de mon fichier 2, la 3ème ligne de mon fichier 3.
Or j'ai besoin que ça me copie la ligne 1 à 5 de tous mes fichiers.
Est-ce qu'il faut remplacer Do While par For Each ?
Peux-tu m'aider ?
Merci d'encore
jvstn a écrit :Re-bonjour,
J'avance bien avec tes conseils, merci !
Mais ça me copie-colle la 1ère ligne de mon fichier 1, la 2ème ligne de mon fichier 2, la 3ème ligne de mon fichier 3.
Or j'ai besoin que ça me copie la ligne 1 à 5 de tous mes fichiers.
re-bonjour,
le code que je t'ai fourni copie les cellule B6,C6 et B7 (ce que j'ai compris que tu souhaitais faire en voyant ton premier code) de chaque fichier sur une nouvelle ligne dans la synthèse. Ce dont tu parles ici correspond à un autre code et une autre demande. dis-moi ce qu'il faut copier de chaque fichier ?
un exemple des 2 fichiers type (source et target) aiderait...
Oui en effet, désolée.
Je souhaite copier la plage B6:Q10 de chaque fichier de chaque worksheet VBA dans le worksheet recap.
Merci !
Julie
Bonjour,
essaie ceci (non testé)
Sub recuperation()
'Déclarer les variables
Dim target_wb As Workbook 'fichier récapitulatif
Dim target_ws As Worksheet 'feuille récapitulative
Dim source_path As String 'dossier source
Dim source_wb_name As String 'nom fichier source
Dim source_wb As Workbook 'fichier source
Dim source_ws As Worksheet 'feuille source
'Désactiver le rafraîchissement de l'écran avant la macro
Application.ScreenUpdating = False
'Ouvrir la feuille source du fichier source
Set target_wb = ThisWorkbook
source_path = "C:\Users\Julie\Documents\Entreprise\Outil évaluation \" 'Modification nécessaire en cas de changement d'ordinateur
Set target_ws = target_wb.Worksheets("Récupération des données")
dlr = target_ws.Cells(Rows.Count, "B").End(xlUp).Row + 1 'dernière ligne utilisée sur la feuille récapitulative
source_wb_name = Dir(source_path & "\*.xlsx")
Do While source_wb_name <> ""
Workbooks.Open source_path & source_wb_name
Set source_wb = ActiveWorkbook
On Error GoTo suivant
Set source_ws = source_wb.Worksheets("VBA")
With target_ws
On Error GoTo 0
source_ws.Range("B6:Q10").Copy .Range("B" & dlr)
dlr = dlr + 5 'on a copié 5 lignes
End With
source_wb.Close False
suite:
On Error GoTo 0
source_wb_name = Dir()
Loop
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""VBA"" dans le fichier " & source_wb_name, vbExclamation:
source.Close False: Resume suite
MsgBox "une erreur" & Err.Number & "est survenue"
End SubCa ne fonctionne pas.. J'ai également tenté :
Range("B" & dlr).Value = source_ws.Range("B6:Q10")
dlr = dlr + 5 'on ajoute 5 lignes sur target_wsbonjour,
problème avec les cellules fusionnées, correction
Sub recuperation()
'Déclarer les variables
Dim target_wb As Workbook 'fichier récapitulatif
Dim target_ws As Worksheet 'feuille récapitulative
Dim source_path As String 'dossier source
Dim source_wb_name As String 'nom fichier source
Dim source_wb As Workbook 'fichier source
Dim source_ws As Worksheet 'feuille source
'Désactiver le rafraîchissement de l'écran avant la macro
Application.ScreenUpdating = False
'Ouvrir la feuille source du fichier source
Set target_wb = ThisWorkbook
source_path = "C:\Users\Julie\Documents\Entreprise\Outil évaluation \" 'Modification nécessaire en cas de changement d'ordinateur
Set target_ws = target_wb.Worksheets("Récupération des données")
dlr = target_ws.Cells(Rows.Count, "B").End(xlUp).Row + 1 'dernière ligne utilisée sur la feuille récapitulative
If dlr = 5 Then dlr = 6
source_wb_name = Dir(source_path & "1.xlsx")
Do While source_wb_name <> ""
Workbooks.Open source_path & source_wb_name
Set source_wb = ActiveWorkbook
On Error GoTo suivant
Set source_ws = source_wb.Worksheets("VBA")
With target_ws
On Error GoTo 0
source_ws.Range("B6:Q10").Copy .Range("B" & dlr)
dlr = dlr + 5 'on a copié 5 lignes
End With
source_wb.Close False
suite:
On Error GoTo 0
source_wb_name = Dir()
Loop
Exit Sub
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""VBA"" dans le fichier " & source_wb_name, vbExclamation:
Source.Close False: Resume suite
MsgBox "une erreur" & Err.Number & "est survenue"
End SubNous dé-fusionné les cellules qui posaient problème au début, mais le problème persiste.
Ca copie bien en boucle mais uniquement la cellule B6 de chaque fichier du répertoire.
Voici le code que nous avons fait jusqu'à présent, merci pour ton aide :
Sub recuperation()
'Déclarer les variables
Dim target_wb As Workbook 'fichier récapitulatif
Dim target_ws As Worksheet 'feuille récapitulative
Dim source_path As String 'dossier source
Dim source_wb_name As String 'nom fichier source
Dim source_wb As Workbook 'fichier source
Dim source_ws As Worksheet 'feuille source
Dim dlr As Long
'Désactiver le rafraîchissement de l'écran avant la macro
Application.ScreenUpdating = False
'Ouvrir la feuille source du fichier source
Set target_wb = ThisWorkbook
source_path = "C:\Users\Julie\Documents\Gécina\Outil évaluation Gecina\" 'Modification nécessaire en cas de changement d'ordinateur
Set target_ws = target_wb.Worksheets("Récupération des données")
dlr = target_ws.Cells(Rows.Count, "B").End(xlUp).Row 'dernière ligne utilisée sur la feuille récapitulative
source_wb_name = Dir(source_path & "\*.xlsx")
Do While source_wb_name <> ""
'le fichier est ouvert via l'instruction workbook.open, une fois le fichier ouvert
'il devient actif et le lien entre source et le fichier se fait par l'instruction set source=activeworkbook
If source_wb_name <> target_wb.Name Then
Workbooks.Open source_path & source_wb_name
Set source_wb = ActiveWorkbook
On Error GoTo suivant
Set source_ws = source_wb.Worksheets("VBA")
With target_ws
On Error GoTo 0
dlr = dlr + 5 'on ajoute 1 ligne sur target_ws
.Range("B" & dlr).Value = source_ws.Range("B6:Q10").Value
End With
source_wb.Close False
End If
suite:
On Error GoTo 0
source_wb_name = Dir()
Loop
Exit Sub
suivant:
If Err.Number = 9 Then MsgBox "Pas de feuille ""VBA"" dans le fichier " & source_wb_name, vbExclamation: source_wb.Close False: Resume suite
MsgBox "une erreur" & Err.Number & "est survenue"
End Subbonsoir,
pourquoi tu ne prends pas le code que j'ai fourni ?
Bonsoir,
Je l’ai testé mais ça n’a pas fonctionné..
Du coup j’en ai essayé d’autres pour capter la plage de cellules.
Julie
jvstn a écrit :Bonsoir,
Je l’ai testé mais ça n’a pas fonctionné..
Du coup j’en ai essayé d’autres pour capter la plage de cellules.
Julie
ce code fonctionne chez moi, avec les fichiers que tu as fournis. (sans modifier les cellules fusionnées).