Compilation de fichiers avec critère

Bonjour à tous,

Le code qui est présenté ci-dessous permet de compiler des fichiers au sein d'une même feuille. Ce que je souhaiterais faire, c'est uniquement compiler les colonnes où l'en tête commence par : "Status Cocode …" au sein de ses différents fichiers.

Je ne peux pas utiliser un Range puisque le nombre de colonne comportant "Status Cocode …" varient suivants les fichiers (entre 1 et 5)

Je vous insère ci dessous le code que j'utilise pour compiler les fichiers, et je vous mets en PJ un exemple de fichier sur lequel j'aimerais extraire uniquement les "Status Cocode …"

Merci d'avance

Sub collecter()
Dim wbk1 As Workbook, wbk2 As Workbook, ws1 As Worksheet
Dim MonRepertoire, Repertoire As FileDialog, monFichier$, derL%, derL1%

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1) & "\"

    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.ActiveSheet
    Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(MonRepertoire & "*.xlsx")

    Do While monFichier <> ""
        ws1.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Select
        derL = ws1.Cells(Rows.Count, 3).End(xlUp).Row + 1
        Set wbk2 = Workbooks.Open(MonRepertoire & monFichier)
        wbk2.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Cells.Copy
        ws1.Paste
        ws1.Range("B" & derL & ":B" & ws1.Cells(Rows.Count, 3).End(xlUp).Row) = wbk2.Name
        Application.DisplayAlerts = False
            wbk2.Close False
        Application.DisplayAlerts = True
        Rows(derL).Delete Shift:=xlUp
        monFichier = Dir
    Loop

End Sub

Théo

Bonjour Théo

Tiens, je retrouve mon code !

Ajoute en tête :

Dim depuis As Range, jusque As Range

Remplace

wbk2.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Cells.Copy

par

    Set depuis = wbk2.ActiveSheet.Rows("1:1").Find(What:="Status Cocode", After:=wbk2.ActiveSheet.Range("A1"), LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    Set jusque = depuis.End(xlToRight).End(xlDown)
    Range(depuis, jusque).Copy

Hello Steelson

Oui effectivement c'est bien ton code !

J'ai un problème lorsque je lance lance macro :

" Run-time Error '91':

Object variable or With Block Variable not Set"

A la ligne :

 Set jusque = depuis.End(xlToRight).End(xlDown)

Le code complet :

Sub collecter()
Dim wbk1 As Workbook, wbk2 As Workbook, ws1 As Worksheet
Dim MonRepertoire, Repertoire As FileDialog, monFichier$, derL%, derL1%

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1) & "\"

    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.ActiveSheet
    Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(MonRepertoire & "*.xlsx")

    Do While monFichier <> ""
        ws1.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Select
        derL = ws1.Cells(Rows.Count, 3).End(xlUp).Row + 1
        Set wbk2 = Workbooks.Open(MonRepertoire & monFichier)
        Set depuis = wbk2.ActiveSheet.Rows("1:1").Find(What:="Status Cocode", After:=wbk2.ActiveSheet.Range("A1"), LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        Set jusque = depuis.End(xlToRight).End(xlDown)
        Range(depuis, jusque).Copy
        ws1.Paste
        ws1.Range("B" & derL & ":B" & ws1.Cells(Rows.Count, 3).End(xlUp).Row) = wbk2.Name
        Application.DisplayAlerts = False
            wbk2.Close False
        Application.DisplayAlerts = True
        Rows(derL).Delete Shift:=xlUp
        monFichier = Dir
    Loop

End Sub

Hello fausse manip de ma part

Tout est good, petite question :

Comment faire pour que uniquement ces colonnes soit copiées côte à côté, colonne après colonne?

Et garder le nom de l'en tête de la colonne lors du collage

Merci )

C'est good pour l'en tête, mais je ne vois pas comment coller les colonnes les unes à côtés des autres

Merci

Bonjour,

Pas sûr d'avoir bien compris ta demande !

Au lieu de mettre les valeurs les unes en dessous des autres, tu veux les mettre cote à cote ? C'est bien cela ?

Dans ce cas, change

        ws1.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Select

en

        ws1.Cells(1,columns.count).End(xltoleft).Offset(0,1).Select

C'est top merci !

Dernière question et je te laisse tranquille

Est-il possible d'uniquement venir copier/coller les colonnes contenant l'en-tête "Status Cocode..."?

Parce que actuellement, ca vient effectivement copier/coller la/les colonnes "Status Cocode..." mais également tout ce qu'il se situe après.

Merci encore,

Théo

ok, j'ai été un peu vite dans la lecture ... cela va être un peu plus complexe !

je regarde

Je n'ai pas pu tester faute de l'ensemble des fichiers ... donc à essayer

Sub collecter()
Dim wbk1 As Workbook, wbk2 As Workbook, ws1 As Worksheet
Dim MonRepertoire, Repertoire As FileDialog, monFichier$, derL%, derC%, col%

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1) & "\"

    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.ActiveSheet
    Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(MonRepertoire & "*.xlsx")

    Do While monFichier <> ""
        ws1.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Select
        derC = Selection.Column
        derL = ws1.Cells(Rows.Count, 3).End(xlUp).Row + 1
        Set wbk2 = Workbooks.Open(MonRepertoire & monFichier)
        Set depuis = wbk2.ActiveSheet.Rows("1:1").Find(What:="Status Cocode", After:=wbk2.ActiveSheet.Range("A1"), LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        Set jusque = depuis.End(xlToRight).End(xlDown)
        Range(depuis, jusque).Copy
        ws1.Paste
        ws1.Range("B" & derL & ":B" & ws1.Cells(Rows.Count, 3).End(xlUp).Row) = wbk2.Name
        Application.DisplayAlerts = False
            wbk2.Close False
        Application.DisplayAlerts = True
        'Rows(derL).Delete Shift:=xlUp
        For col = ws1.Cells(1, Columns.Count).End(xlToLeft).Column To derC Step -1
            If Not Cells(1, col) Like "Status*" Then Columns(col).Delete Shift:=xlToLeft
        Next
        monFichier = Dir
    Loop

End Sub

C'est nickel !

Ca fonctionne parfaitement merci )