copier la même colonne provenant d'une centaine de fichiers

 'Nécéssite d'activer la référence Microsoft ADO Ext x.x for DLL and Security
'Nécéssite d'activer la référence Microsoft ActiveX Data Objects x.x Library
 
Dim Direction As String, Fichier As String
Dim NomFeuille As String, texte_SQL As String
Dim Cn As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim oCat As ADOX.Catalog
 
Direction = "C:\Documents and Settings\mimi\dossier\02dvracmod 3"
Fichier = Dir(Direction & "\*.xls", 0)
 
 
'Boucle sur les fichiers du répertoire
Do While Len(Fichier) > 0
    
Set Cn = New ADODB.Connection
    '--- Connection ---
    With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Data Source=" & Direction & "\" & Fichier & _
            ";Extended Properties=Excel 8.0;"
        .Open
    End With
    '-----------------
 
    '--- Récupère le nom de la feuille:
    'Cet exemple suppose que le classeur contient une seule feuille et
    'aucune plage nommée.
    Set oCat = New ADOX.Catalog
    Set oCat.ActiveConnection = Cn
    NomFeuille = oCat.Tables(0).Name
 
 
    'Définit la requête:
    'récupère les données de la colonne G dons l'entête s'appelle "moy"
    texte_SQL = "SELECT moy FROM [" & NomFeuille & "]"
 
    Set Rst = New ADODB.Recordset
    Set Rst = Cn.Execute(texte_SQL)
 
    Cells(Range("A65535").End(xlUp).Row + 1, 1).CopyFromRecordset Rst
 
    Set oCat = Nothing
    Set Rst = Nothing
    '--- Fermeture connection ---
    Cn.Close
    Set Cn = Nothing
   
    Fichier = Dir()
Loop
 
MsgBox "Terminé"

Cells(Range("A65535").End(xlUp).Row + 1, 1).CopyFromRecordset Rst

ActiveSheet.Cells(ActiveSheet.Range("A65535").End(xlUp).Row + 1, 1).CopyFromRecordset Rst

    With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Data Source=" & Direction & "\" & Fichier & _
            ";extended properties=""Excel 8.0;IMEX=1"""
        .Open
    End With