Ik heb er dit van gemaakt maar dat kan best eleganter of niet?
Sub finale()
Dim a, i As Long, txt As String, w
a = Cells(21, 1).CurrentRegion.Value
''a = Range("A21:F" & Range("A" & Rows.Count).End(xlUp).Row)
Range("A21:F" & Cells(Rows.Count, 1).End(xlUp).Row).Clear
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
txt = Join(Array(a(i, 1), a(i, 6)), Chr(2))
If Not .exists(txt) Then
.Item(txt) = VBA.Array(a(i, 1), " ", " ", a(i, 4), a(i, 5), a(i, 6))
Else
w = .Item(txt): w(3) = w(3) + a(i, 4)
.Item(txt) = w
End If
Next
a = .items: i = .Count
End With
If Range("F22") = "" Then
MsgBox "Er is niets te bestellen"
Exit Sub
Else
End If
Range("a21").Resize(i, 6).Value = Application.Index(a, 0, 0) ''range = welke rij hij wegschrijft
End Sub