Copier coller des données de plusieurs dans un fichier récapitulatif

Bonjour, pour mon stage je dois automatiser le dépouillement des résultats par VBA.

J'ai donc 12 classeurs correspondant à chaque mois de l'année. Un fichier Excel récapitulatif a été créer, celui-ci contient 12 feuilles une pour chaque mois. L'objectif est de copier les données des 12 classeurs dans les feuilles correspondantes du fichier récapitulatif.

J'ai réussi à le faire avec ce code mais j'aimerai essayer avec une boucle pour faciliter l'écriture.

Pouvez-vous m'aider s'il vous plaît merci .

Sub test()

Dim SourceFile As String, ThisFile As String, ShtToCopy As String, SourceFile2 As String
Dim Ws As Workbook, wf As Workbook
 Dim sht As Worksheet

    SourceFile = Dir("/Users/raphael-guillaume/Desktop/Essai/un.xls")
    ThisFile = Dir("/Users/raphael-guillaume/Desktop/Essai/Classeur4.xlsx")
    ShtToCopy = "Feuil1"

    SourceFile2 = Dir("/Users/raphael-guillaume/Desktop/Essai/deux.xls")

    On Error Resume Next
    Set Ws = Workbooks(SourceFile)
    If Ws Is Nothing Then Workbooks.Open SourceFile

    Set wf = Workbooks(ThisFile)
    If wf Is Nothing Then Workbooks.Open ThisFile
    On Error GoTo 0

    Workbooks(SourceFile).Worksheets(ShtToCopy).Activate
    Cells.Copy
    Workbooks(ThisFile).Worksheets("Janvier").Activate
    Range("A1").Select: ActiveSheet.Paste: Range("A1").Select
    Application.CutCopyMode = False
    Range("A1").Select
Workbooks("un.xls").Close False
On Error Resume Next
    Set Ws = Workbooks(SourceFile2)
    If Ws Is Nothing Then Workbooks.Open SourceFile2

    Set wf = Workbooks(ThisFile)
    If wf Is Nothing Then Workbooks.Open ThisFile
    On Error GoTo 0

    Workbooks(SourceFile2).Worksheets(ShtToCopy).Activate
    Cells.Copy
    Workbooks(ThisFile).Worksheets("Fevrier").Activate
    Range("A1").Select: ActiveSheet.Paste: Range("A1").Select
    Application.CutCopyMode = False
    Range("A1").Select
    Workbooks("deux.xls").Close False

Bonjour,

Voici un exemple, est ce que ça convient ?

Sub Lire_Mois()
Dim Fich As String, rep As String, FeuilSource As String, Feuil_cellule_destination As String
rep = "/Users/raphael-guillaume/Desktop/Essai/"
arrMois = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
m = 0
Fich = Dir(rep & "*.*")
Do While Len(Fich) > 0
  FeuilSource = "Feuil1"
  Feuil_cellule_destination = arrMois(m) & "!A1"
  LireCellule rep, Fich, FeuilSource, Feuil_cellule_destination
  m = m + 1
  Fich = Dir()
Loop
End Sub

'nécessite d'activer la référence: Microsoft ActiveX Data Objects xx Library
Function LireCellule(repertoire As String, Fichier As String, Feuille As String, dest As String)
  Set cnn = New ADODB.Connection
'--- Connexion ---
 With cnn
        .Provider = "Microsoft.Jet.OLEDB.12.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
           & repertoire & "\" & Fichier & ";Extended Properties=""Excel 12.0;HDR=NO;"""
       .Open
 End With
'--- récupérer les données --
 Set rs = cnn.Execute("SELECT * FROM [" & Feuille & "$" & cellule & "]")
  Range(dest).CopyFromRecordset rs

  rs.Close
  cnn.Close
  Set rs = Nothing
  Set cnn = Nothing
End Function