Extraction multiples VBA

Bonjour,

Je suis en train de réaliser une macro pour extraire les données depuis plusieurs fichiers xls.

Je souhaite extraire les données des feuil1 de chaque fichier (qui sont dans un dossier commun) en spécifiant la colonne et la plage de ligne à prendre en compte (extraire les toutes les données présentes dans la colonne G, de la ligne 6 à 20 uniquement)

La matrice semble fonctionner dans le sens ou elle va ouvrir le fichier extrait (tous)les éléments, referme le fichier puis passe au second.

Le problème, c'est comment indiquer de copier uniquement les données de la colonne G et ensuite de les coller dans la colonne A et d'ajouter un saut de ligne entre les résultats pour éviter des compiler.

Malgré des recherches dans le forum je n'ai pas trouvé d'exemples pour m'aider.

Merci par avance de votre aide.

Voici le code réalisé avec les fichiers

Sub Extraction()
Dim principal As ThisWorkbook
Dim repertoire As String, fichier As String
    Application.ScreenUpdating = False
    Set principal = ThisWorkbook
    repertoire = "C:\Users\.................................."
    ChDir repertoire
    fichier = Dir("*.xls")
    Do While fichier <> ""
        If fichier <> principal.Name Then
            Workbooks.Open fichier
            On Error GoTo suivant
            With Sheets("Feuil1")
                On Error GoTo 0
                On Error Resume Next
                .Range ("A1:A" & .[b65536].End(xlUp).Row)
                .UsedRange.EntireRow.Copy Destination:=principal.Sheets(1).[a65536].End(xlUp).Offset(1)
            End With
            ActiveWorkbook.Close False
        End If
suivant:
        If Err.Number = 9 Then MsgBox "Pas de feuille ""Feuil1"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
        fichier = Dir
    Loop
End Sub

Bonjour,

proposition de correction à tester ...

Sub Extraction()
Dim principal As ThisWorkbook
Dim repertoire As String, fichier As String
    Application.ScreenUpdating = False
    Set principal = ThisWorkbook
    repertoire = "C:\Users\.................................."
    ChDir repertoire
    fichier = Dir("*.xls")
    Do While fichier <> ""
        If fichier <> principal.Name Then
            Workbooks.Open fichier
            On Error GoTo suivant
            With Sheets("Feuil1")
                On Error GoTo 0
                On Error Resume Next
                .Range("G1:G" & .[G65536].End(xlUp).Row).Copy Sheets(1).Cells(Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 2, 1)
            End With
            ActiveWorkbook.Close False
        End If
suivant:
        If Err.Number = 9 Then MsgBox "Pas de feuille ""Feuil1"" dans le fichier " & fichier, vbExclamation: ActiveWorkbook.Close False
        fichier = Dir
    Loop
End Sub

Salut h2so4,

Apparemment, le code transmis ne marche pas.

J'ai cependant trouvé une solution que je partage si cela peut aide quelqu'un.

Sub Extraction2()
    Dim Principal As ThisWorkbook
    Dim Repertoire As String, fichier As String
    Application.ScreenUpdating = False
    Set Principal = ThisWorkbook
    'Repertoire = "C:\Users\........................................................................"
    Repertoire = ThisWorkbook.Path
    ChDir Repertoire
    xFichier = Dir("*.xls")
    Do While xFichier <> ""
        If xFichier <> Principal.Name Then
            xLig = ActiveSheet.Range("A65536").End(xlUp).Row + 2
            Call LireFichierFermé(Repertoire, xFichier, xLig)
        End If
        xFichier = Dir
    Loop
End Sub

Module

Sub LireFichierFermé(xChemin, xFichier, xLig)
    On Error GoTo SiErreur
    Dim xTexte_SQL As String
    Dim xOnglet As String
    Dim xPlage As String
    Application.ScreenUpdating = False
    'Définition des variables
        xOnglet = "Feuil1"
        xPlage = "G6:G20"
    'Connexion ADO
        Set Source = CreateObject("ADODB.Connection")
        'Avant XL 2007
            Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;data source=" & xChemin & "\" & xFichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
        'Après XL 2007
            'Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xChemin & "\" & xFichier & ";Extended Properties=""Excel 12.0;HDR=NO;"";"       'IMEX=1";
    'Exerce la requete ADO sur les donnée à recopier
        xTexte_SQL = "SELECT * FROM [" & xOnglet & "$" & xPlage & "]"
        Set Requete = CreateObject("ADODB.Recordset")
        Set Requete = Source.Execute(xTexte_SQL)
    'Ecriture des données lues dans le fichier en cours
        ActiveSheet.Range("A" & xLig).CopyFromRecordset Requete
    'Ferme la requete
        Set Requete = Nothing
        Set Source = Nothing
        Application.ScreenUpdating = True
        Exit Sub
SiErreur:
        MsgBox "Pas de feuille ""Feuil1"" dans le fichier " & xFichier, vbExclamation
End Sub

h2so4,

Merci pour ton aide et du temps passé sur ma demande.

A pluch