XL 2010 fusionner 2 tableaux avec même id -macro

Sub ImporterDatasPatient()
    Dim wk As Workbook
    Dim plg1 As Range, plg2 As Range
    Dim Nips As Variant, Nips2 As Variant, idxNip As Variant
    Dim i As Integer, nbcols As Integer
   
    Application.ScreenUpdating = False
    '
    ' Obtenir le classeur source
    On Error Resume Next
    '
    ' Voir s'il est déjà ouvert
    Set wk = Workbooks("djam28-2.xlsx")
    '
    ' S'il ne l'est pas, l'ouvrir
    If wk Is Nothing Then
        Set wk = Workbooks.Open(ThisWorkbook.Path & "\djam28-2.xlsx")
    End If
    On Error GoTo 0
    '
    ' Plage destination des données
    Set plg1 = ThisWorkbook.Sheets("Feuil1").Range("A1").CurrentRegion
    '
    ' Valeurs des Nips dans un tableau en mémoire pour aller plus vite
    Nips = plg1.Columns(1).Value
    '
    ' Destination des données1
    Set plg1 = plg1.Offset(, plg1.Columns.Count).Columns(1)
    '
    ' Source des données
    Set plg2 = wk.Sheets("Feuil1").Range("A1").CurrentRegion
    '
    ' Conserver le nombre de colonnes
    nbcols = plg2.Columns.Count
    '
    ' Nips source en tableau
    Nips2 = plg2.Columns(1).Value
    '
    ' En démarrant en 1 on importe les entêtes de plg2
    For i = 1 To UBound(Nips)
        '
        ' Chercher le Nip en cours dans le tableau Nips2
        idxNip = Application.Match(Nips(i, 1), Nips2, 0)
        '
        ' S'il est trouvé, importer les données
        If Not IsError(idxNip) Then
            plg1.Cells(i, 1).Resize(1, nbcols).Value = plg2.Cells(idxNip, 1).Resize(, nbcols).Value
        End If
    Next i
    '
    ' Fermer le classeur source sans l'enregistrer
    wk.Close False
    Application.ScreenUpdating = True
End Sub

Sub Fusionner()
Dim d As Object, P1 As Range, P2 As Range, nlig1&, nlig2&, ncol1%, ncol2%, i&, r As Range, n&, j&
Set P1 = Sheets("1").[A1].CurrentRegion 'à adapter
Set P2 = Sheets("2").[A1].CurrentRegion 'à adapter
nlig1 = P1.Rows.Count
nlig2 = P2.Rows.Count
ncol1 = P1.Columns.Count
ncol2 = P2.Columns.Count - 1
Application.ScreenUpdating = False
With Sheets("Fusion") 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.Delete 'RAZ
    .[A1].Resize(nlig1, ncol1) = P1.Value
    .[A1].Offset(nlig1).Resize(nlig2) = P2.Columns(1).Value
    .[A1].Offset(nlig1, ncol1).Resize(nlig2, ncol2) = P2.Columns(2).Resize(, ncol2).Value
    With .[A1].CurrentRegion
        .Sort .Columns(1), xlAscending, Header:=xlYes 'tri pour regrouper
        For i = .Rows.Count To 2 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                Set r = .Cells(Application.Match(.Cells(i, 1), .Columns(1), 0), 1).Resize(Application.CountIf(.Columns(1), .Cells(i, 1)), ncol1)
                If Application.CountA(r.Rows(1)) > 1 Then
                    n = 0
                    For j = 2 To r.Rows.Count
                        If Application.CountA(r.Rows(j)) = 1 Then n = n + 1 'compte les lignes vides
                    Next j
                    n = Application.Min(n, r.Rows.Count - n)
                    With r.Offset(r.Rows.Count - n, ncol1).Resize(n, ncol2)
                        .Offset(n - r.Rows.Count) = .Value
                        .EntireRow.Delete
                    End With
                    i = r.Row
                End If
            End If
        Next i
        .Borders.Weight = xlThin 'bordures
        .Columns.AutoFit 'ajustement largeurs
    End With
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
End Sub

Sub Fusionner()
Dim d As Object, P1 As Range, P2 As Range, nlig1&, nlig2&, ncol1%, ncol2%, i&, r As Range, n&, j&
Set P1 = Sheets("1").[A1].CurrentRegion.Offset(1) 'à adapter
Set P2 = Sheets("2").[A1].CurrentRegion.Offset(1) 'à adapter
nlig1 = P1.Rows.Count
nlig2 = P2.Rows.Count
ncol1 = P1.Columns.Count
ncol2 = P2.Columns.Count - 1
Application.ScreenUpdating = False
With Sheets("Fusion") 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Cells.Delete 'RAZ
    P1.Rows(0).Copy .[A1] 'en-têtes
    P2(0, 2).Resize(, ncol2).Copy .[A1].Offset(, ncol1) 'en-têtes
    .[A2].Resize(nlig1, ncol1) = P1.Value
    .[A2].Offset(nlig1).Resize(nlig2) = P2.Columns(1).Value
    .[A2].Offset(nlig1, ncol1).Resize(nlig2, ncol2) = P2.Columns(2).Resize(, ncol2).Value
    With .UsedRange
        .Sort .Columns(1), xlAscending, Header:=xlYes 'tri pour regrouper
        .Rows(.Rows.Count).EntireRow.Delete 'la dernière ligne est vide
        For i = .Rows.Count To 2 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                Set r = .Cells(Application.Match(.Cells(i, 1), .Columns(1), 0), 1).Resize(Application.CountIf(.Columns(1), .Cells(i, 1)), ncol1)
                If Application.CountA(r.Rows(1)) > 1 Then
                    n = 0
                    For j = 2 To r.Rows.Count
                        If Application.CountA(r.Rows(j)) = 1 Then n = n + 1 'compte les lignes vides
                    Next j
                    n = Application.Min(n, r.Rows.Count - n)
                    With r.Offset(r.Rows.Count - n, ncol1).Resize(n, ncol2)
                        .Offset(n - r.Rows.Count) = .Value
                        .EntireRow.Delete
                    End With
                    i = r.Row
                End If
            End If
        Next i
        .Borders.Weight = xlThin 'bordures
        .Columns.AutoFit 'ajustement largeurs
    End With
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
End Sub