Microsoft 365 Réorganiser les données selon la clé

Option Explicit

Sub fusion()
   Dim d1 As Object, a, b, c, n As Integer, m As Integer, i As Integer, p As Integer
   Set d1 = CreateObject("Scripting.Dictionary")
   With ActiveSheet
      a = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row)
      b = .Range("C1:D" & .Range("A" & Rows.Count).End(xlUp).Row)
      n = UBound(a) + UBound(b)
      ReDim c(1 To n, 1 To 3)
      m = 0
      For i = LBound(a) To UBound(a)
         If Not d1.exists(a(i, 1)) Then m = m + 1: d1(a(i, 1)) = m: p = m Else p = d1(a(i, 1))
         c(p, 1) = a(i, 1): c(p, 2) = a(i, 2)
      Next i
      For i = LBound(b) To UBound(b)
         If Not d1.exists(b(i, 1)) Then m = m + 1: d1(b(i, 1)) = m: p = m Else p = d1(b(i, 1))
         c(p, 1) = b(i, 1): c(p, 3) = b(i, 2)
      Next i
      .[G1].CurrentRegion.ClearContents
      .[G1].Resize(d1.Count, UBound(c, 2)) = c
   End With
End Sub

a = .Range("A1:B" & .Range("A" & Rows.Count).End(xlUp).Row)' Remplace A1 par A4'
b = .Range("C1:D" & .Range("A" & Rows.Count).End(xlUp).Row)' Remplace C1 par C4'

Sub test()
Dim Code1 As Object: Set Code1 = CreateObject("Scripting.Dictionary") 'Ici j'instenci une collection
'Un Dictionary comporte Un Clé {Key} et une Valeur
'Code1.exists("TOTO") retourn true si TOTO existe dans la collection
'Code1.Add "TOTO",10 ajoute la clé TOTO a la collection avec la valeur 10
'MsgBox  Code1("TOTO") afichie un le message 10!
Dim L As Integer, Out As Range
Set Out = ThisWorkbook.Sheets("Feuil1").Range("F1") 'ici Je mémorise la première célulle de mon table de sorti

'jesuprime tout ce sui ce trouve en desous de la     barre de tire, en rouge,de mon tableau de sortie!
With Out.CurrentRegion
If .Cells.Rows.Count > 1 Then Range(.Range("A2"), .Cells(.Cells.Rows.Count, "C")).Delete
End With

With ThisWorkbook.Sheets("Feuil1").Range("A1").CurrentRegion 'je memorise mon tableau d'entré en jaune
For i = 2 To .Rows.Count 'je parcour mon tableau d'entré de la ligne 2 à la dernière
If Trim(.Cells(i, "A").Value) <> "" Then 'notes que dans une plage la première celulle est toujour A1 Range("C10").range("A1")="TOTO"
'Code1 sauvegarde la ligne ou serra sauvegardé les code P048A se fera à la ligne 2 te tableau de sortie en rose
If Not Code1.exists(.Cells(i, "A").Value) Then Code1.Add .Cells(i, "A").Value, Out.CurrentRegion.Rows.Count + 1
Out.Cells(Code1(.Cells(i, "A").Value), "A") = .Cells(i, "A") 'en  Out.Cells(Code1("P048A"), "A")="P048A" par exemple
Out.Cells(Code1(.Cells(i, "A").Value), "B") = .Cells(i, "B") 'en  Out.Cells(Code1("P048A"), "B")="1" par exemple
End If
If Trim(.Cells(i, "C").Value) <> "" Then
If Not Code1.exists(.Cells(i, "C").Value) Then Code1.Add .Cells(i, "C").Value, Out.CurrentRegion.Rows.Count + 1 'P048D Par Exemple
Out.Cells(Code1(.Cells(i, "C").Value), "A") = .Cells(i, "C") 'en  Out.Cells(Code1("P048A"), "A")="P048A" par exemple
Out.Cells(Code1(.Cells(i, "C").Value), "C") = .Cells(i, "D") 'en  Out.Cells(Code1("P048A"), CA")="2" par exemple
End If

Next
End With
End Sub