Microsoft 365 Copier des données avec conditions à l'aide d'une macro

Sub MAJ()
Dim chemin$, fichier$, sep1$, sep2$, d As Object, tablo, i&, x$, xx$, s, j%, y$, n&, dest As Range
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "BDD.xlsx" 'à adapter
sep1 = " " 'séparateur 1ère colonne
sep2 = "-" 'séparateur 2ème colonne
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
On Error Resume Next
Workbooks(fichier).Close False 'si le fichier est ouvert
Err = 0
With Workbooks.Open(chemin & fichier)
    If Err Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
    tablo = .Sheets(1).UsedRange.Resize(, 2) 'matrice, plus rapide
    .Close False
End With
On Error GoTo 0
For i = 1 To UBound(tablo)
    x = tablo(i, 1): xx = tablo(i, 2)
    If x <> "" And xx <> "" Then
        x = Split(x, sep1)(0)
        s = Split(xx, sep2)
        For j = 0 To UBound(s)
            xx = Trim(s(j))
            y = x & Chr(1) & xx
            If Not d.exists(y) Then
                d(y) = ""
                n = n + 1
                tablo(n, 1) = x: tablo(n, 2) = xx
            End If
        Next j
    End If
Next i
'---restitution---
With Feuil1 'CodeName
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set dest = .[B3] '1ère cellule du tableau, à adapter
    With .Cells(.Rows.Count, dest.Column).End(xlUp)(2) '1ère cellule vide
        If n Then
            .Resize(n, 2) = tablo
            .Resize(n, 3).Borders.Weight = xlThin 'bordures
        End If
    End With
    dest.CurrentRegion.RemoveDuplicates Array(1, 2), Header:=xlNo 'supprime les doublons
End With
End Sub

With Workbooks.Open(chemin & fichier)
    If Err Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
    tablo = .Sheets(1).UsedRange.Resize(, 3) 'matrice, plus rapide, sur 3 colonnes
    .Close False
End With
On Error GoTo 0
For i = 1 To UBound(tablo)
    x = tablo(i, 1): xx = tablo(i, 3)

Sub MAJ()
Dim chemin$, fichier$, sep1$, sep2$, tablo, i&, x$, xx$, s, j%, n&, dest As Range
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = "BDD.xlsx" 'à adapter
sep1 = " " 'séparateur 1ère colonne
sep2 = "-" 'séparateur 2ème colonne
Application.ScreenUpdating = False
On Error Resume Next
Workbooks(fichier).Close False 'si le fichier est ouvert
Err = 0
With Workbooks.Open(chemin & fichier)
    If Err Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
    tablo = .Sheets(1).UsedRange.Resize(, 3) 'matrice, plus rapide, sur 3 colonnes
    .Close False
End With
On Error GoTo 0
For i = 1 To UBound(tablo)
    x = tablo(i, 1): xx = tablo(i, 3)
    If x <> "" And xx <> "" Then
        x = Split(x, sep1)(0)
        s = Split(xx, sep2)
        For j = 0 To UBound(s)
            xx = Trim(s(j))
            n = n + 1
            tablo(n, 1) = x: tablo(n, 2) = xx
        Next j
    End If
Next i
'---restitution---
With Feuil1 'CodeName
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set dest = .[B3] '1ère cellule du tableau, à adapter
    With .Cells(.Rows.Count, dest.Column).End(xlUp)(2) '1ère cellule vide
        If n Then
            .Resize(n, 2) = tablo
            .Resize(n, 3).Borders.Weight = xlThin 'bordures
        End If
        
    End With
    dest.CurrentRegion.RemoveDuplicates Array(1, 2), Header:=xlNo 'supprime les doublons
    .Range(.Cells(.Rows.Count, dest.Column).End(xlUp)(2), .Rows(.Rows.Count)).Delete 'car il y a des lignes vides en bas du Usedrange
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub