Fichier Recap automatique

Bradvid

XLDnaute Occasionnel
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.
 

Pièces jointes

  • Tableau1.xls
    13.5 KB · Affichages: 60
  • Tableau recap.xls
    13.5 KB · Affichages: 72
  • Tableau2.xls
    13.5 KB · Affichages: 67
  • Tableau1.xls
    13.5 KB · Affichages: 62
  • Tableau recap.xls
    13.5 KB · Affichages: 70
  • Tableau2.xls
    13.5 KB · Affichages: 70
  • Tableau1.xls
    13.5 KB · Affichages: 57
  • Tableau recap.xls
    13.5 KB · Affichages: 69
  • Tableau2.xls
    13.5 KB · Affichages: 71

tototiti2008

XLDnaute Barbatruc
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
 

tototiti2008

XLDnaute Barbatruc
Re : Fichier Recap automatique

Bonjour,

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

Code:
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
 

tototiti2008

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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

XLDnaute Occasionnel
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....
 

Pièces jointes

  • Message erreur.xls
    23.5 KB · Affichages: 58
  • Message erreur.xls
    23.5 KB · Affichages: 54
  • Message erreur.xls
    23.5 KB · Affichages: 52

tototiti2008

XLDnaute Barbatruc
Re : Fichier Recap automatique

Voilà un code qui devrait fonctionner en 2007 :

Code:
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 :

Code:
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
 

Discussions similaires