Microsoft 365 Fusionner 2 fichiers excel avec nom spécifique

[Erakmur]

Bonjour,
Je souhaite que dans un fichier excel il y est un bouton Fusionné. Quand on clique dessus, il va chercher 2 fichiers excels commençant par tabledemande_JourD'aujourdhui qu'il va fusionner dans un onglet appelé DI et 2 autres fichiers excels commançant par tablebp_JourD'aujourdhui qu'il va fusionner dans un onglet qu'il va appelé BP.

Les fichiers s'appels tabledemande_AnnéeMoisJour_HeureMinuteSeconde et tablebp_AnnéeMoisJour_HeureMinuteSeconde.
Par exemple, je viens d'extraire tablebp est il s'appel tablebp_20240522_154106 parce que je l'ai extrait le 22 mai à 15h41min et 6s

Donc aujourd'hui j'aurai 2 fichiers commençant par tabledemande_20240522 et 2 fichiers commançant par tablebp_20240522.
Dans l'onglet DI, j'aurai donc la fusion des 2 fichiers tabledemande_20240522 et dans onglet BP la fusion des 2 fichiers commençant par tablebp_20240522. Il fusionne les 2 fichiers du jour d'aujourd'hui.

Pour la fusion, je pense qu'il doit copier le permier fichier et qu'à la première ligne vierge rencontrée, il rajoute le second fichier.

Quelqu'un peut il m'aider ?
Cordialement

 

[job75]

Bonsoir Erakmur,

Téléchargez les 2 fichiers "Tabledemande" dans le même dossier et les 2 autres fichiers "Tablebp" dans le même dossier, téléchargez le fichier xlsm où vous voulez, ouvrez-le et exécutez la macro :

Sub Fusion()
Dim critere, feuille, n, fichier, d As Object, i, a, w As Worksheet, P As Range, dest As Range
critere = Array("tabledemande", "tablebp")
feuille = Array("DI", "BP")
For n = 0 To UBound(feuille)
1   MsgBox "Sélectionnez 2 fichiers dont le nom commence par """ & critere(n) & """"
    fichier = Application.GetOpenFilename("Fichiers .xlsx (*.xlsx), *.xlsx", MultiSelect:=True)
    If IsArray(fichier) Then
        Set d = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(fichier)
            If LCase(fichier(i)) Like "*" & critere(n) & "*" Then d(fichier(i)) = ""
        Next i
        If d.Count <> 2 Then GoTo 1
        a = d.keys
        Application.ScreenUpdating = False
        For i = 0 To 1
            Set w = Workbooks.Open(a(i)).Sheets(1)
            Set P = w.Range("A1", w.UsedRange)
            With ThisWorkbook.Sheets(feuille(n))
                If i Then Set dest = .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1) Else .Cells.Clear: Set dest = .Cells(1)
                P.Copy dest
                .Columns.AutoFit 'ajustement largeurs
            End With
            w.Parent.Close False
        Next i
        Application.ScreenUpdating = True
        MsgBox "Les 2 fichiers """ & critere(n) & """ ont été fusionnés, voyez la feuille """ & feuille(n) & """"
    End If
Next n
End Sub

A+

 

[job75]

Bonjour Erakmur, le forum,

La macro précédente fusionne les 2 fichiers quelles que soient leurs dates.

Avec celle-ci les dates doivent être les mêmes :

Sub Fusion()
Dim critere, feuille, n, fichier, d As Object, i, nomfich$, dat$, a, b, w As Worksheet
critere = Array("Tabledemande", "Tablebp")
feuille = Array("DI", "BP")
ChDir ThisWorkbook.Path
For n = 0 To UBound(feuille)
1   MsgBox "Sélectionnez 2 fichiers dont le nom commence par """ & critere(n) & """"
2   fichier = Application.GetOpenFilename("Fichiers .xlsx (*.xlsx), *.xlsx", MultiSelect:=True)
    If IsArray(fichier) Then
        Set d = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(fichier)
            If LCase(fichier(i)) Like "*" & LCase(critere(n)) & "_########*" Then
                nomfich = Dir(fichier(i))
                dat = Mid(nomfich, Len(critere(n)) + 2, 8)
                d(fichier(i)) = dat
            End If
        Next i
        If d.Count <> 2 Then GoTo 1
        a = d.keys: b = d.items
        If b(0) <> b(1) Then MsgBox "Les 2 fichiers """ & critere(n) & """ doivent avoir la même date...": GoTo 2
        Application.ScreenUpdating = False
        For i = 0 To 1
            Set w = Workbooks.Open(a(i)).Sheets(1)
            With ThisWorkbook.Sheets(feuille(n))
                If i = 0 Then .Cells.Delete: .Cells(1) = "Date " & dat
                w.Range("A1", w.UsedRange).Copy .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1)
                .Columns.AutoFit 'ajustement largeurs
            End With
            w.Parent.Close False
        Next i
        Application.ScreenUpdating = True
        MsgBox "Les 2 fichiers """ & critere(n) & "_" & dat & """ ont été fusionnés" & vbLf & vbLf & "Voyez la feuille """ & feuille(n) & """"
    End If
Next n
End Sub

A+

 

[Erakmur]

Bonjour Job75, très intéressant ! Il y a néanmoins un soucis.
1) Vous avez insérer sur la ligne 1 Date > Il ne faut pas.
2) Il se trouve que les 2 fichiers ont des titres de colonnes. Du coup j'ai 2 fois les titres de colonnes. On peut imaginer que la ligne1 des onglets DI et BP restent vierges et que les 2 fichiers sont copiés à partir de la ligne 2.
Pouvez vous effectuer les modifications ?

 

[job75]

1) Vous avez insérer sur la ligne 1 Date > Il ne faut pas.

Je pense qu'il faut cette information, c'est la seule qui permet de savoir quels fichiers ont été fusionnés.

Pour les en-têtes il suffit de supprimer celles du 2èmes fichier si elles sont bien identiques au 1er :

Sub Fusion()
Dim critere, feuille, n, fichier, d As Object, i, nomfich$, dat$, a, b, w As Worksheet
critere = Array("Tabledemande", "Tablebp")
feuille = Array("DI", "BP")
ChDir ThisWorkbook.Path
For n = 0 To UBound(feuille)
1   MsgBox "Sélectionnez 2 fichiers dont le nom commence par """ & critere(n) & """"
2   fichier = Application.GetOpenFilename("Fichiers .xlsx (*.xlsx), *.xlsx", MultiSelect:=True)
    If IsArray(fichier) Then
        Set d = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(fichier)
            If LCase(fichier(i)) Like "*" & LCase(critere(n)) & "_########*" Then
                nomfich = Dir(fichier(i))
                dat = Mid(nomfich, Len(critere(n)) + 2, 8)
                d(fichier(i)) = dat
            End If
        Next i
        If d.Count <> 2 Then GoTo 1
        a = d.keys: b = d.items
        If b(0) <> b(1) Then MsgBox "Les 2 fichiers """ & critere(n) & """ doivent avoir la même date...": GoTo 2
        Application.ScreenUpdating = False
        For i = 0 To 1
            Set w = Workbooks.Open(a(i)).Sheets(1)
            With ThisWorkbook.Sheets(feuille(n))
                If i = 0 Then .Cells.Delete: .Cells(1) = "Date " & dat
                If i Then w.UsedRange(i).EntireRow.Delete 'supprime les en-têtes
                w.UsedRange.Copy .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1)
                .Columns.AutoFit 'ajustement largeurs
            End With
            w.Parent.Close False
        Next i
        Application.ScreenUpdating = True
        MsgBox "Les 2 fichiers """ & critere(n) & "_" & dat & """ ont été fusionnés" & vbLf & vbLf & "Voyez la feuille """ & feuille(n) & """"
    End If
Next n
End Sub

 

[Erakmur]

Merci, c'est exactement se qu'il me fallait !