XL 2010 Boucle pour macro "copier-coller"

[Assenav]

Bonjour à tous,

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:

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)

Bien cdlt

 

[Patrice33740]

Bonjour,

Essaies ce code :

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

 

[Lone-wolf]

Bonjour Assenav

Bienvenue sur XLD et bonne année

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

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

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.


EDIT: Bonjour Patrice

 

[Assenav]

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:

    Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"

(à 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!

Bonne soirée

 

[Assenav]

Bonjour,

Essaies ce code :

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

Bonjour Patrice,

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

 

[Patrice33740]

Re,

Sans ouvrir les fichiers :

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

 

[Lone-wolf]

Bonsoir Assenav

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.

 

[Assenav]

Re,

Sans ouvrir les fichiers :

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?)

Bien cordialement

 

[Patrice33740]

Bon...jour,

Essaies ce code,
tu peux définir la plage d'origine (mais sur 1 ligne uniquement)
et la première cellule de destination :

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