Option Explicit
Sub test2()
Dim a, w(), e, s, i As Long, j As Long, n As Long
Dim dico As Object, txt1 As String, txt2 As String
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
txt1 = Join$(Array(a(i, 3), a(i, 6)), " - ")
txt2 = Join$(Array(a(i, 6), a(i, 3)), " - ")
If Not dico.exists(txt1) Then
Set dico(txt1) = CreateObject("Scripting.Dictionary")
dico(txt1).CompareMode = 1
If txt1 <> txt2 Then
Set dico(txt2) = Nothing
End If
If Not dico(txt1).exists(a(i, 1)) Then
ReDim w(1 To UBound(a, 2), 1 To 2)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2) - 1) = a(1, j)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt1)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt1)(.Cells(i, 1).Value) = Union(.Rows(1), .Rows(i))
End If
Else
If dico(txt1) Is Nothing Then
If Not dico(txt2).exists(a(i, 1)) Then
ReDim w(1 To UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt2)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt2)(.Cells(i, 1).Value) = .Rows(i)
Else
w = dico(txt2)(a(i, 1))
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt2)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt2)(.Cells(i, 1).Value) = Union(dico(txt2)(.Cells(i, 1).Value), .Rows(i))
End If
Else
If Not dico(txt1).exists(a(i, 1)) Then
ReDim w(1 To UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt1)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt1)(.Cells(i, 1).Value) = .Rows(i)
Else
w = dico(txt1)(a(i, 1))
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt1)(a(i, 1)) = w
'équivalence du code précédent
'Set dico(txt1)(.Cells(i, 1).Value) = Union(dico(txt1)(.Cells(i, 1).Value), .Rows(i))
End If
End If
End If
Next
Application.ScreenUpdating = False
'restitution
With Sheets("Feuil2")
.Cells.Clear
For Each e In dico
If Not dico(e) Is Nothing Then
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 3
If n = 4 Then n = 1
With .Cells(n, 1).Resize(, 7)
.Merge
.HorizontalAlignment = xlCenter
.Value = UCase(e)
.Font.Size = 16
End With
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 1
For Each s In dico(e)
w = dico(e)(s)
.Cells(n, 1).Resize(UBound(w, 2), UBound(w, 1)).FormulaLocal = _
Application.Transpose(w)
n = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row + 2
Next
End If
Next
.Cells.EntireColumn.AutoFit
With .UsedRange.Rows
.SpecialCells(4).RowHeight = 9
.SpecialCells(2).RowHeight = 18
End With
.Activate
End With
Application.ScreenUpdating = True
Set dico = Nothing
End Sub
