While..wend VBA (copier valeurs de plusieurs classeurs)

Question

Je viens vous soumettre un problème auquel j'espère vous pourrez apporter un début de solution! Je vous explique donc le cas d'étude : J'ai une multitude fichiers Excel qui ont tous exactement le même modèle (même nombre de colonnes/lignes remplient), et dans lesquels je souhaite récupérer uniquement la valeur de certaines cellules pour chacun de ces fichiers. (On va appeler ces fichiers test1.xlsm et test2.xlsm) J'ai réussi à intégrer une Macro trouvé sur internet, que j'ai pu l'adapté à mon cas. Elle me permet d'obtenir un classeur Excel (on le nomme recap.xlsm) qui reprend certaines plages de cellules provenant des autres fichiers Excel (test1.xlsm et test2.xlsm) Le code VBA que j'utilise va copier les cellules des différents classeurs qui sont tous situés dans un unique dossier. Mon soucis est le suivant, lors que j'ajoute un nouveau classeur (par exemple test3.xlsm) dans le dossier où sont rangés les autres fichiers excel, si je lance ma macro depuis l'Excel Recap.xlsm, ce dernier qui comprenait déjà les valeurs de test1.xlsm et test2.xlsm, va rajouter à la suite de nouveau les valeurs de test1 test2 puis test3. En outre, dans le fichier recap j'aurai comme données, les valeurs de test1,test2,test1,test2 et test3. Pour palier à ce problème, j'ai en début de code le "Cells.Delete". Cela permet de tout nettoyer, et de recommencer la macro depuis le départ. Voila ce qui me dérange : comme j'ai un nombre non négligeables de fichiers Excel et que ma macro prend énormément de temps à tout copier car elle recommence depuis le début, je voulais savoir s'il était possible de trouver une alternative au cells.delete. Je voudrai que ma macro copie uniquement les valeurs que des nouveaux classeurs, et pas ceux dont elle a déjà les infos. Dans notre cas, si j'avais lancé la macro pour test1.xlsm et test2.xlsm; je voudrai qu'à l'ajout de test3.xlsm, la macro ne reprends pas la valeur des 2 premiers fichiers, mais ajoute uniquement à la suite les valeurs du test3.xlsm. Auriez-vous une solution ou un début de piste à me proposer? Je suis preneur de toutes infos! Vous trouverez à la fin de mon message le code utilisé. Je vous mets également en pièce-jointe le fichier excel qui me sers de test. Je vous remercie d'avance pour toute aide apportée! Sub Auto_() ' Initialisation ' -------------- Cells.Delete Range("A1") = "Nom fichier" Range("B1") = "Titre" Range("C1") = "Auteur" Range("D1") = "code" Range("A1:H1").Font.Bold = True ' Parcours de tous les fichiers ' ----------------------------- ChDir "c:\COUCOU" test = Dir("c:\COUCOU\*.xlsm") While Len(test) &gt; 0 Workbooks.Open test Range("C3:C3").Copy Workbooks("Recap.xlsm").Activate Range("B" &amp; ActiveSheet.UsedRange.Rows.Count + 1).Select Selection.PasteSpecial Paste:=xlPasteValues Application.DisplayAlerts = False Workbooks.Open test AvantDerniereLigne = ActiveSheet.UsedRange.Rows.Count - 1 Range("C9:C9").Copy Workbooks("Recap.xlsm").Activate DebutNomFichier = ActiveSheet.UsedRange.Rows.Count + 0 Range("C" &amp; ActiveSheet.UsedRange.Rows.Count + 0).Select Selection.PasteSpecial Paste:=xlPasteValues Application.DisplayAlerts = False Workbooks.Open test AvantDerniereLigne = ActiveSheet.UsedRange.Rows.Count - 1 Range("H3:H3").Copy Workbooks("Recap.xlsm").Activate DebutNomFichier = ActiveSheet.UsedRange.Rows.Count + 0 Range("D" &amp; ActiveSheet.UsedRange.Rows.Count + 0).Select Selection.PasteSpecial Paste:=xlPasteValues Application.DisplayAlerts = False Range("A" &amp; DebutNomFichier &amp; ":A" &amp; ActiveSheet.UsedRange.Rows.Count) = test Workbooks(test).Close test = Dir Wend End Sub...

Banzai64 · Accepted Answer

Bonjour et bienvenu(e)

Sans test

Sub Auto_()  ' Initialisation
Dim Chemin As String, Test As String
Dim Ws As Worksheet
Dim Ligne As Long

  Application.ScreenUpdating = False
  Set Ws = ActiveSheet
  Ligne = Range("A" & Rows.Count).End(xlUp).Row + 1
  Chemin = "C:\COUCOU\"
' --------------
  'Cells.Delete
  Range("A1") = "Nom fichier"
  Range("B1") = "Titre"
  Range("C1") = "Auteur"
  Range("D1") = "code"

  Range("A1:H1").Font.Bold = True

  ' Parcours de tous les fichiers
  ' -----------------------------
  'ChDir "c:\COUCOU"
  Test = Dir(Chemin & "*.xlsm")
  Do While Test <> ""
    If Test <> ThisWorkbook.Name Then
      If Application.CountIf(Ws.Columns("A"), Test) = 0 Then
        With Workbooks.Open(Chemin & Test)
          With .Sheets("Feuil1")
            Ws.Range("A" & Ligne) = Test
            Ws.Range("B" & Ligne) = .Range("C3")
            Ws.Range("C" & Ligne) = .Range("C9")
            Ws.Range("D" & Ligne) = .Range("H3")
            Ligne = Ligne + 1
          End With
          .Close savechanges:=False
        End With
      End If
    End If
    Test = Dir()
  Loop
End Sub

Si pas ça fournis dans une archive les fichiers "test..."