Bonsoir à tous,
Comme ceci :
Option Explicit
Sub test()
Dim a, w(), dico As Object, i As Long, n As Long
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Feuil1").Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
If IsEmpty(a(i, 11)) Then a(i, 11) = "présent"
If Not dico.exists(a(i, 11)) Then
If i = 2 Then
ReDim w(1 To 6, 1 To 3)
w(1, 1) = a(1, 2): w(2, 1) = a(1, 3)
w(3, 1) = a(1, 4): w(4, 1) = a(1, 11)
w(5, 1) = a(1, 12): w(6, 1) = a(1, 13)
w(4, 2) = a(i, 11)
Else
ReDim w(1 To 6, 1 To 2)
w(4, 1) = a(i, 11)
End If
Else
w = dico(a(i, 11))
ReDim Preserve w(1 To 6, 1 To UBound(w, 2) + 1)
End If
w(1, UBound(w, 2)) = a(i, 2): w(2, UBound(w, 2)) = a(i, 3)
w(3, UBound(w, 2)) = a(i, 4): w(4, UBound(w, 2)) = a(i, 11)
w(5, UBound(w, 2)) = a(i, 12): w(6, UBound(w, 2)) = a(i, 13)
dico(a(i, 11)) = w
Next
End With
Application.ScreenUpdating = False
'restitution et mise en forme
With Sheets("feuil2").Range("a1")
.CurrentRegion.Cells.Clear
For i = 0 To dico.Count - 1
With .Offset(n).Resize(UBound(dico.items()(i), 2), UBound(dico.items()(i), 1))
.Value = Application.Transpose(dico.items()(i))
.BorderAround Weight:=xlThin
If i = 0 Then
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
End With
With .Rows(2)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 40
End With
Else
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 40
End With
End If
End With
n = n + UBound(dico.items()(i), 2)
Next
.CurrentRegion.Columns.AutoFit
End With
Application.ScreenUpdating = True
Set dico = Nothing
End Sub
klin89