Fusion de fichiers en automatique

Bonjour,

Je cherche à fusionner des tableaux ayant la même forme en copiant une sélection sur une extraction d'un logiciel.

Cependant je n'arrive pas à copier les couleurs.

Le fichier récup données est sensé récupérer les données de l'onglet "produit dans une zone des documents (Bid-1 et Col-1)

Qqun aurait la solution?

Martin

martinc a écrit :

Bonjour,

Je cherche à fusionner des tableaux ayant la même forme en copiant une sélection sur une extraction d'un logiciel.

Cependant je n'arrive pas à copier les couleurs

Bonjour,

Les structures de données ne sont pas exactement identiques : quelques colonnes de plus sur l'un mais surtout un fichier est structuré en tableau pas l'autre.

Voici une solution ...

Option Explicit

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet

    Dim chemin$, monFichier$, derL%, onglet$

Sub collecter()

    chemin = Sheets("Param").Range("A1")
    onglet = "Produits"

    Set wbk1 = ThisWorkbook
    Set ws1 = wbk1.Sheets(onglet)
    ws1.Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    monFichier = Dir(chemin & "*.xlsx")

    Do While monFichier <> ""
        ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
        derL = ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
        If Not monFichier Like "*.xlsm" Then
            Set wbk2 = Workbooks.Open(chemin & monFichier)
            Set ws2 = wbk2.Sheets(onglet)
            ws2.Range("A6:DL" & ws2.Range("A" & Rows.Count).End(xlUp).Row).Copy
            ws1.Paste
            Application.DisplayAlerts = False
                wbk2.Close False
            Application.DisplayAlerts = True
            Rows(derL).Delete Shift:=xlUp
        End If
        monFichier = Dir
    Loop

End Sub