Fichier Recap automatique

[Bradvid]

Bonjour,

J'ai plusieurs fichiers contenant 1 seul onglet avec le même tableau à l'intérieur mais contenant des informations diffrentes (il n'y a pas forcément le même nombre de ligne dans chaque tableau mais obligatoirement les mêmes colonnes).

Je souhaiterai récupérer dans un autre fichier le même tableau consolidant les informations contenues dans les deux fichiers existants en automatique via une macro.

je joins des fichiers exemples...

Merci pour votre aide.

 

[tototiti2008]

Re : Fichier Recap automatique

Bonjour Bradvid,

Comment gères-tu la liste de fichiers à ouvrir pour tout fusionner ?
Ils se trouvent tous dans un même dossier ?
Tu taperas leur chemin dans une liste Excel ?

 

[Bradvid]

Re : Fichier Recap automatique

Salut Tototiti2008,

je gère ça dans la macro directement en indiquant le chemin du dossier dans lequel se trouve les fichiers....le chemin sera toujours le même.

Merci pout on aide.

 

[tototiti2008]

Re : Fichier Recap automatique

Juste quelques idées (je vais devoir partir) :
Utilise FileSearch pour trouver la liste des fichiers à traiter
Boucle sur tous les fichiers trouvés :
Ouvre le fichier
Copie la liste (sans la 1ère ligne)
Colle la à la suite dans ton classeur résultat

bon courage

 

[Bradvid]

Re : Fichier Recap automatique

Comprends pas tout....
quequ'un à une idée avec une macro qui va bien?

Merci.

 

[Bradvid]

Re : Fichier Recap automatique

Aucune idée?
Je suis sur que quelqu'un peut m'aider.....

Merci encore...

 

[tototiti2008]

Re : Fichier Recap automatique

Bonjour,

Teste ça et dis-mois si ça fonctionne :

Sub ParcoursFichiers()
Dim FD As FileDialog, FS As FileSearch, Chemin As String
Dim Wkb As Workbook
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    FD.AllowMultiSelect = False
    FD.Title = "Choix du dossier"
    FD.InitialView = msoFileDialogViewList
    FD.InitialFileName = "C:\"
    If FD.Show <> 0 Then
        Chemin = FD.SelectedItems(1)
    End If
    ThisWorkbook.ActiveSheet.Range("A2:B65536").ClearContents
    Set FS = Application.FileSearch
    With FS
    .NewSearch
    .LookIn = Chemin
    .SearchSubFolders = False
    .Filename = "*.xls"
    If .Execute() > 0 Then
    For i = 1 To .FoundFiles.Count
        Set Wkb = Workbooks.Open(.FoundFiles(i))
        Wkb.Worksheets("Feuil1").Activate
        Wkb.Worksheets("Feuil1").Range("A2:C" & ActiveSheet.Range("C65536").End(xlUp).Row).Copy
        ThisWorkbook.ActiveSheet.Paste Destination:=ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0)
        Wkb.Close False
    Next i
    End If
    End With
End Sub

 

[Bradvid]

Re : Fichier Recap automatique

Merci beaucoup!
c'est génial!
possible de faire un coller valeur plûtot qu'un paste?

Merci encore pour ton aide précieuse!

 

[tototiti2008]

Re : Fichier Recap automatique

Oui, remplace

ThisWorkbook.ActiveSheet.Paste Destination:=ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0)

par

ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

 

[Bradvid]

Re : Fichier Recap automatique

Oui, remplace

ThisWorkbook.ActiveSheet.Paste Destination:=ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0)

par

ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Merci, ça fonctionne bien.
j'ai juste le message suivant qui apparaît (fichier joint), il n'est pas bloquant mais j'aimerais qu'il n'apparaisse pas si possible.....
Tu peux encore m'aider?

 

[Bradvid]

Re : Fichier Recap automatique

Merci, ça fonctionne bien.
j'ai juste le message suivant qui apparaît (fichier joint), il n'est pas bloquant mais j'aimerais qu'il n'apparaisse pas si possible.....
Tu peux encore m'aider?

Oui, remplace

ThisWorkbook.ActiveSheet.Paste Destination:=ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0)

par

ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Avec le message d'erreur c mieux....

 

[Bradvid]

Re : Fichier Recap automatique

J'ai trouvé comment faire disparaître le message avec le code suivant :

Application.CutCopyMode = False

Merci encore pour ton aide et bonne journée.

 

[Bradvid]

Re : Fichier Recap automatique

tototiti2008,

J'ai un petit problème quand je etste la macro sur Excel 2007.

Il n'aime pas Application.FileSearch....

Est ce un code différent en 2007?

Merci pour ton aide.

 

[tototiti2008]

Re : Fichier Recap automatique

Oui, FileSearch a disparu en Excel 2007.
Laisses-moi un peu de temps, je te donnes un code qui fonctionne sous 2007

 

[tototiti2008]

Re : Fichier Recap automatique

Voilà un code qui devrait fonctionner en 2007 :

Sub ParcoursFichiers()
Dim FD As FileDialog, Chemin As String
Dim Wkb As Workbook
Dim a As String
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    FD.AllowMultiSelect = False
    FD.Title = "Choix du dossier"
    FD.InitialView = msoFileDialogViewList
    FD.InitialFileName = "C:\"
    If FD.Show <> 0 Then
        Chemin = FD.SelectedItems(1)
    Else
        Exit Sub
    End If
    ThisWorkbook.ActiveSheet.Range("A2:C65536").ClearContents
    a = Dir(Chemin & "\*.xls")
        If a <> "" Then
            Do
                Set Wkb = Workbooks.Open(a)
                Wkb.Worksheets("Feuil1").Activate
                Wkb.Worksheets("Feuil1").Range("A2:C" & Wkb.Worksheets("Feuil1").Range("C65536").End(xlUp).Row).Copy
                ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                Wkb.Close False
                a = Dir
            Loop Until a = ""
        End If
    Application.CutCopyMode = False
End Sub

J'en profite pour apporter quelques corrections au code 2003 :

Sub ParcoursFichiers()
Dim FD As FileDialog, FS As FileSearch, Chemin As String
Dim Wkb As Workbook
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    FD.AllowMultiSelect = False
    FD.Title = "Choix du dossier"
    FD.InitialView = msoFileDialogViewList
    FD.InitialFileName = "C:\"
    If FD.Show <> 0 Then
        Chemin = FD.SelectedItems(1)
    Else
        Exit Sub
    End If
    ThisWorkbook.ActiveSheet.Range("A2:C65536").ClearContents
    Set FS = Application.FileSearch
    With FS
    .NewSearch
    .LookIn = Chemin
    .SearchSubFolders = False
    .Filename = "*.xls"
    If .Execute() > 0 Then
    For i = 1 To .FoundFiles.Count
        Set Wkb = Workbooks.Open(.FoundFiles(i))
        Wkb.Worksheets("Feuil1").Activate
                Wkb.Worksheets("Feuil1").Range("A2:C" & Wkb.Worksheets("Feuil1").Range("C65536").End(xlUp).Row).Copy
                ThisWorkbook.ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Wkb.Close False
    Next i
    End If
    End With
    Application.CutCopyMode = False
End Sub