Je viens de débuter dans les macros VBA et je cherche à automatiser un copier-coller pour constituer un tableau récap dans lequel pourraient naviguer facilement.
Je cherche à créer une macro qui effectuera la tache suivante:
A partir d'un dossier qui regroupera plusieurs fichiers nommés "MissMond1.xls", "MissMond2", 3 (etc...), il faudrait que ma macro recopie la ligne 2 (ou la plage "A2: D2") de l'onglet "feuil2" de chacun des fichiers du répertoire et qu'il les aligne dans l'onglet "feuil1" d'un fichier "recap"
La ligne2 de l'onglet feuil2 de MissMond1 devra se retrouver dans le fichier Récap, en ligne 2
La ligne2 de l'onglet feuil2 de MissMond2 devra se retrouver dans le fichier Récap, en ligne 3
La ligne2 de l'onglet feuil2 de MissMond3 devra se retrouver dans le fichier Récap, en ligne 4
La ligne2 de l'onglet feuil2 de MissMond4 devra se retrouver dans le fichier Récap, en ligne 5
et ainsi de suite...
J'ai réussi à obtenir le résultat que je voulais avec la macro ci-dessous, mais le seul pbme, c'est qu'elle ne copie qu'une seule ligne (celle du premier fichier)!! Il faut sûrement que j'utilise une boucle mais je n'arrive pas à savoir laquelle..."FOR"? "NEXT FOR"?
Voilà ma macro:
VB:
Sub Test1()
Dim Wb As Workbook
Workbooks.Open "C:\Macro_test\DdeMissMond1.xls"
Workbooks("DdeMissMond1.xls").Activate
Worksheets("feuil2").Activate
ActiveWindow.WindowState = xlNormal
Range("A2:D2").Select
Selection.Copy
Windows("Recap.xlsm").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("DdeMissMond1.xls").Close
End Sub
Pouvez-vous me dire ce que vous en pensez et me donner des pistes pour avancer rapidement svp?
Dsl du derangement...j'espère que vous pourrez m'aider, je devrais avoir abouti d'ici mercredi... :/
(j'ai une réunion jeudi)
Sub Test1()
Const chemin$ = "C:\Macro_test\"
Dim fichier As String
Dim rng As Range
Set rng = ThisWorkbook.Worksheets(1).Range("A2:D2")
rng.Resize(1000).ClearContents 'Adapter au nombre max de fichiers
fichier = Dir(chemin & "DdeMissMond*.xls")
Application.ScreenUpdating = False
Do While Len(fichier) > 0
With Workbooks.Open(chemin & fichier)
rng.Value = .Worksheets("Feuil2").Range("A2:D2").Value
Set rng = rng.Offset(1)
.Close
fichier = Dir
End With
Loop
Application.ScreenUpdating = True
End Sub
Dans le classeur de destination crée une nouvelle feuille du nom de("Classeurs"). Inscrit en colonne A (à partir de la cellule 2) tous les noms des classeurs sources; Ensuite
Pour lister les classeurs
VB:
Option Explicit
Sub List_Fichiers()
Dim Fichiers_Repertoire(10000, 1)
Dim Fichier As String, Rep As String, Nom_Rep As String
Dim Nb_Fichiers As Long, lig As Long
With Sheets("Recap")
.Range("a2:d65536").ClearContents
End With
With Sheets("Classeurs")
.Range("a2:a1000").ClearContents
End With
Fichier = Dir$("C:\Macro_test\" & "*.*")
Do While Fichier <> ""
Fichiers_Repertoire(Nb_Fichiers, 0) = Fichier
Fichier = Dir$
Nb_Fichiers = Nb_Fichiers + 1
Loop
Nb_Fichiers = 0
While Fichiers_Repertoire(Nb_Fichiers, 0) <> Nom_Rep
Sheets("Classeurs").Range("a2").Offset(Nb_Fichiers, 0).Value = Fichiers_Repertoire(Nb_Fichiers, 0)
Nb_Fichiers = Nb_Fichiers + 1
Wend
With Sheets("Classeurs")
lig = .Range("a" & Rows.Count).End(xlUp).Row
.Range("a:a").Columns.AutoFit
If .Cells(lig, 1) <> "" Then Call RecupDonnees
End With
End Sub
Pour récupérer les données
VB:
Sub RecupDonnees()
'Activer les deux références ci-dessous; onglet Outils > Références
'Microsoft ActiveX Data Objects 2.8 Library
'Microsoft ADO ext 2.8 for DLL and Security
Dim Source As ADODB.Connection
Dim Fichier As String, Feuille As String, Cellules As String
Dim plage As Range, plg As Range, cel As Range
Dim ADOCommand As ADODB.Command, Rst As ADODB.Recordset, t
With Sheets("Classeurs")
Set plg = .Range("a2:a" & .Range("a" & Rows.Count).End(xlUp).Row)
For Each cel In plg
Fichier = "C:\Macro_test\" & cel.Value
Feuille = "Feuil2$"
Cellules = "A2:D2"
Set Source = New ADODB.Connection
Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
Set ADOCommand = New ADODB.Command
With ADOCommand
.ActiveConnection = Source
.CommandText = "SELECT * FROM [" & Feuille & Cellules & "]"
End With
Set Rst = New ADODB.Recordset
Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
Set Rst = Source.Execute("[" & Feuille & Cellules & "]")
Set plage = Sheets("Recap").Range("a65536").End(xlUp)(2)
plage.CopyFromRecordset Rst
Next cel
End With
Rst.Close
Source.Close
Set Source = Nothing
Set Rst = Nothing
Set ADOCommand = Nothing
End Sub
Avec la méthode ADODB, c'est plus rapide et évite d'ouvrir les classeurs comme le fait Workbooks.open. Imagine si tu en as une centaine.
Bonjour LoneWolf,
Merci! Bonne année 2017 à toi aussi!
Merci pour cette réponse...
Je n'ai pas vu tout de suite la consigne que tu avais écrite dans le code concernant l'activation des extensions suivantes:
Microsoft ActiveX Data Objects 2.8 Library
Microsoft ADO ext 2.8 for DLL and Security
(Etant grande débutante, j'aurais capté l'info plus facilement si tu me l'avais indiquée dans ton message direct plutôt que dans le code j'avoue...mais bon....ça rajoute un peu de sel...!)
Ceci dit, une fois qu'on active ces "références" que sont "Microsoft ActiveX Data Objects 2.8 Library" et "Microsoft ADO ext 2.8 for DLL and Security", ça marche!
L'action que je voulais exécuter se produit, les données correctes sont bien récupérées!
Seul soucis: excel n'est pas content et il conclut l'exec de la macro par un message d'erreur (cf.pj):
Si je suis sa suggestion et que je tape sur la touche "débogage", c'est cette partie du code que je vois apparaître, surlignée au jaune:
(à croire qu'Excel n'est pas copain avec les "Habilitations à Diriger la Recherche", autrement dit "HDR"!.... loliloul!)
...Je ne sais pas si cela t'éclaire mais en tout cas, ce n'est pas grave!!...le solution de Patrice me convient parfaitement!
Mon dossier ne risque de ne jamais contenir plus de 100 fichiers, au vu du nb de demandes habituel...Au-delà, les fichiers seront probablement archivés et on passera à une nouvelle année...
Mais merci qd même pour le coup de main! Si Excel ne me sortait pas de pop-up d'erreur d'exécution, ta solution marchait aussi bien que celle de Patrice!
Sub Test1()
Const chemin$ = "C:\Macro_test\"
Dim fichier As String
Dim rng As Range
Set rng = ThisWorkbook.Worksheets(1).Range("A2:D2")
rng.Resize(1000).ClearContents 'Adapter au nombre max de fichiers
fichier = Dir(chemin & "DdeMissMond*.xls")
Application.ScreenUpdating = False
Do While Len(fichier) > 0
With Workbooks.Open(chemin & fichier)
rng.Value = .Worksheets("Feuil2").Range("A2:D2").Value
Set rng = rng.Offset(1)
.Close
fichier = Dir
End With
Loop
Application.ScreenUpdating = True
End Sub
J'ai vraiment bcp de chance que tu te sois penché sur mon pbme!!! Ta solution marche du feu de Dieu!!!
Et ça me semble bcp moins compliqué que le "NEXT FOR" dans lequel je pensais devoir partir.... ! C'est parfait! Même après 10h de recherche et réflexion, je ne suis pas sûre que j'aurais réussi à trouver une solution aussi viable et rapide (je ne vois même pas les fichiers MissMond s'ouvrir et se fermer!!!). Tu m'as littéralement SAUVEE!!
Merci infiniment!!!
Pour reprendre LoneWolf, bonne année 2017!!
Et très bonne soirée
Sub Test1()
Const Chemin$ = "C:\Macro_test\"
Dim fichier As StringDim rng As Range
Dim cel As Range
Set rng = ThisWorkbook.Worksheets(1).Range("A2:D2")
rng.Resize(1000).ClearContents 'Adapter au nombre max de fichiers
fichier = Dir(chemin & "DdeMissMond*.xls")
Application.ScreenUpdating = False
Do While Len(fichier) > 0
For Each cel In rng.Cells
cel.Formula = "='" & chemin & "[" & fichier & "]Feuil2" & "'!" & Split(cel.Address, "$")(1) & "2"
cel.Value = cel.Value
Next cel
Set rng = rng.Offset(1)
fichier = Dir
Loop
Application.ScreenUpdating = True
End Sub
Et en ajoutant On Error resume next - Application.DisplayAlerts = false après les Dim xxx, qu'est-ce que ça donne?. Et moi, si tu aurais mis le fichier, j'aurais pu tester.
Sub Test1()
Const Chemin$ = "C:\Macro_test\"
Dim fichier As StringDim rng As Range
Dim cel As Range
Set rng = ThisWorkbook.Worksheets(1).Range("A2:D2")
rng.Resize(1000).ClearContents 'Adapter au nombre max de fichiers
fichier = Dir(chemin & "DdeMissMond*.xls")
Application.ScreenUpdating = False
Do While Len(fichier) > 0
For Each cel In rng.Cells
cel.Formula = "='" & chemin & "[" & fichier & "]Feuil2" & "'!" & Split(cel.Address, "$")(1) & "2"
cel.Value = cel.Value
Next cel
Set rng = rng.Offset(1)
fichier = Dir
Loop
Application.ScreenUpdating = True
End Sub
Bonsoir Patrice,
Cette macro et encore plus rapide! Encore plus impressionnant!!
J'aurais une petite question...pour l'instant, je ne rapatrie que les données de la plage A2 jusqu'à D2 mais....il est possible que la ligne s'allonge et qu'on rajoute des colonnes... (si tout se passe bien! et je pense que ce sera le cas!!)
Et comme je souhaiterais affecter cette macro à un bouton type "userform", j'aurais besoin de décaler le tableau "recap" sur sa feuille pour laisser de la place au bouton dans le coin supérieur gauche de la page.
Pour cela, il faudrait donc que la plage "A2: D2" (feuil2) du fichier MissMond1 soit récopiée sur la seule feuille du fichier Recap - plage B5:E5
->la plage, "A2: D2" (feuil2) du fichier MissMond2 serait à recopier sur la seule feuille du fichier Recap _plage B6:E6.
->la plage, "A2: D2" (feuil2) du fichier MissMond3 serait à recopier sur la seule feuille du fichier Recap _ plage B7:E7
etc
Je n'ai pas eu de mal à adapter ta première macro dans ce sens, mais pour la 2°, je sèche...
Serait-ce possible de faire cela, avec ta 2° macro? (et pourrais-tu m'aider à savoir comment stp?)
Essaies ce code,
tu peux définir la plage d'origine (mais sur 1 ligne uniquement)
et la première cellule de destination :
VB:
Sub Test1()
Const Chemin$ = "C:\Macro_test\" 'Adapter le répertoire
Const adrOrg$ = "A2:D2" 'Adresse d'origine
Const adrDst$ = "B5" 'Adresse de destination
Dim fichier As String
Dim rngDst As Range
Dim cel As Range
Dim dxC As Integer
With ThisWorkbook.Worksheets(1)
Set rngDst = .Range(adrOrg)
dxC = rngDst.Column
Set rngDst = .Range(adrDst).Resize(1, rngDst.Columns.Count)
dxC = dxC - rngDst.Column
End With
rngDst.Resize(1000).ClearContents 'Adapter au nombre max de fichiers
fichier = Dir(Chemin & "DdeMissMond*.xls")
Application.ScreenUpdating = False
Do While Len(fichier) > 0
For Each cel In rngDst.Cells
cel.Formula = "='" & Chemin & "[" & fichier & "]Feuil2" & "'!" & _
Split(cel.Offset(0, dxC).Address, "$")(1) & "2"
cel.Value = cel.Value
Next cel
Set rngDst = rngDst.Offset(1)
fichier = Dir
Loop
Application.ScreenUpdating = True
End Sub