List Unique Suppliers in Summary

Hmmm, OK maybe I'll give that a try.

To be honest from an output perspective the current methodology gives the ideal result. But if it's that difficult I'll look for another solution.

Try this :-
Results sheet2 from Data on sheet1

Sub MG05May43
Dim Rng As Range, Dn As Range, n As Long, c As Long
Dim Q As Variant
With Sheets("Sheet1")
    Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
    ReDim Ray(1 To Rng.Count, 1 To 3)
    Ray(1, 1) = "Item Code": Ray(1, 2) = "Total": Ray(1, 3) = "Name"
    n = 1

With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .Exists(Dn.Value) Then
        n = n + 1
        Ray(n, 1) = Dn.Value: Ray(n, 2) = Dn.Offset(, 1).Value
        Ray(n, 3) = Dn.Offset(, 2).Value
        .Add Dn.Value, Array(n, 3, Dn.Offset(, 2).Value)
    Else
        Q = .Item(Dn.Value)
            Ray(Q(0), 2) = Ray(Q(0), 2) + Dn.Offset(, 1).Value
            If InStr(Q(2), Dn.Offset(, 2).Value) = 0 Then
                    Q(1) = Q(1) + 1
                    If UBound(Ray, 2) < Q(1) Then ReDim Preserve Ray(1 To Rng.Count, 1 To Q(1))
                Ray(Q(0), Q(1)) = Dn.Offset(, 2).Value
                Ray(1, Q(1)) = "Name"
            End If
        .Item(Dn.Value) = Q
   End If
Next
c = .Count
End With

With Sheets("Sheet2").Range("A1").Resize(c + 1, UBound(Ray, 2))
     .Value = Ray
    .Columns.AutoFit
End With
MsgBox "Run"
End Sub

Regards Mick

Thanks MickG - I'll give that a go!