Bonsoir Vanette, Steelson, le forum
On peut aussi ressortir tes données sous cette forme
Restitution en Feuil2
A tester :
Option Explicit
Sub test()
Dim a, i As Long, j As Long, w(), n As Long, x, y
With Sheets("Feuil1").Cells(1).CurrentRegion
a = .Value
With .Offset(1)
x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(3).Address & ",,,row(1:" _
& .Rows.Count & "))," & .Columns(3).Address & ")=1," & .Columns(3).Address & ",char(2)))"), Chr(2), 0)
y = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(4).Address & ",,,row(1:" _
& .Rows.Count & "))," & .Columns(4).Address & ")=1," & .Columns(4).Address & ",char(2)))"), Chr(2), 0)
End With
End With
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
ReDim w(1 To UBound(y) + 2, 1 To UBound(x) + 2)
w(1, 1) = a(i, 1) & " - " & a(i, 2)
For j = 0 To UBound(x)
w(1, j + 2) = x(j)
Next
For j = 0 To UBound(y)
w(j + 2, 1) = y(j)
Next
Else
w = .Item(a(i, 2))
End If
w(Application.Match(a(i, 4), y, 0) + 1, Application.Match(a(i, 3), x, 0) + 1) = a(i, 7)
.Item(a(i, 2)) = w
Next
y = .items
End With
Application.ScreenUpdating = False
'restitution et mise en forme
With Sheets("Feuil2").Cells(1)
.Resize(, 5).EntireColumn.Clear
For i = 0 To UBound(y)
With .Offset(n).Resize(UBound(y(i), 1), UBound(y(i), 2))
.Value = _
Application.Transpose(Application.Transpose(y(i)))
.Font.Size = 10
.Rows(1).BorderAround Weight:=xlThin
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Offset(1).Resize(.Rows.Count - 1, 1)
.Interior.ColorIndex = 36
End With
With .Offset(, 1).Resize(1, .Columns.Count - 1)
.Interior.ColorIndex = 44
End With
With .Cells(1)
.Font.Size = 11
.Font.Bold = True
.Interior.ColorIndex = 40
End With
End With
n = n + (UBound(y(i), 1)) + 1
Next
With .Resize(, 5).Columns.EntireColumn
.VerticalAlignment = xlCenter
.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub
klin89