Option Explicit
Option Compare Text
Sub test()
Dim a, w(), e, v, i As Long, j As Long, n As Long
Dim dico As Object, client As String
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Résultats")
client = .Cells(1, 2).Value
.UsedRange.Offset(6).Cells.Clear
End With
With Sheets("Articles").Range("a1").CurrentRegion
If WorksheetFunction.CountIf(.Columns(3), client) = 0 Then _
MsgBox "client inexistant": Exit Sub
a = .Value
End With
For i = 2 To UBound(a, 1)
If a(i, 3) = client Then
If Not dico.exists(a(i, 4)) Then
Set dico(a(i, 4)) = CreateObject("Scripting.Dictionary")
dico(a(i, 4)).CompareMode = 1
End If
If Not dico(a(i, 4)).exists(a(i, 2)) Then
ReDim w(1 To 7, 1 To 1)
w(1, 1) = a(i, 1): w(2, 1) = a(i, 2)
For j = 5 To UBound(a, 2)
w(j - 2, 1) = a(i, j)
Next
dico(a(i, 4))(a(i, 2)) = w
End If
End If
Next
a = Sheets("Achats").Range("a1").CurrentRegion.Value2
For Each e In dico.keys
For i = 2 To UBound(a, 1)
If dico(e).exists(a(i, 3)) Then
w = dico(e)(a(i, 3))
If UBound(w, 2) = 1 Then
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 2)
w(2, UBound(w, 2) - 1) = a(1, 1)
For j = 4 To UBound(a, 2)
w(j - 1, UBound(w, 2) - 1) = a(1, j)
Next
Else
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
End If
w(2, UBound(w, 2)) = a(i, 1)
For j = 4 To UBound(a, 2)
w(j - 1, UBound(w, 2)) = a(i, j)
Next
dico(e)(a(i, 3)) = w
End If
Next
Next
For Each e In dico.keys
For Each v In dico(e).keys
If UBound(dico(e)(v), 2) = 1 Then dico(e).Remove v
Next
Next
For Each e In dico.keys
If dico(e).Count = 0 Then dico.Remove e
Next
Application.ScreenUpdating = False
If dico.Count > 0 Then
'Restitution et mise en forme
With Sheets("Résultats").Cells(1)
n = 6
For i = 0 To dico.Count - 1
.Offset(n, 1).Value = dico.keys()(i)
For j = 0 To dico.items()(i).Count - 1
With .Offset(n, 2).Resize(UBound(dico.items()(i).items()(j), 2), UBound(dico.items()(i).items()(j), 1))
With .Offset(2, 1).Resize(.Rows.Count - 2)
.Columns(1).NumberFormat = "dd/mm/yyyy;@"
.Columns(3).NumberFormat = "#,##0.00 $"
End With
.Value = Application.Transpose(dico.items()(i).items()(j))
With .CurrentRegion.Rows(1)
.Cells(1).Resize(, 2).Font.Bold = True
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 2)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Rows(1).Font.Bold = True
With .Font
.Size = 8
.Italic = True
End With
End With
End With
n = n + UBound(dico.items()(i).items()(j), 2) + 1
Next
Next
With .Parent.UsedRange.Offset(6).Cells
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Else
MsgBox "aucun achat effectué par " & client
End If
Set dico = Nothing
Application.ScreenUpdating = True
End Sub