Change to
Sub test()
Dim a, i As Long, w, x As Object
a = Sheets("Currently look like this").Cells(1).CurrentRegion.Value
With CreateObject("System.Collections.SortedList")
For i = 2 To UBound(a, 1)
a(i, 1) = Format$(a(i, 1), String(10, "0"))
a(i, 4) = Format$(a(i, 4), String(10, "0"))
If a(i, 1) <> "" Then
ReDim w(1 To UBound(a, 2))
w(1) = a(i, 1): w(2) = a(i, 2)
.Item(a(i, 1)) = w
End If
Next
For i = 2 To UBound(a, 1)
If a(i, 4) <> "" Then
If Not .contains(a(i, 4)) Then
ReDim w(1 To UBound(a, 2))
w(4) = a(i, 4): w(5) = a(i, 5)
.Item(a(i, 4)) = w
Else
w = .Item(a(i, 4))
w(4) = a(i, 4): w(5) = a(i, 5)
.Item(a(i, 4)) = w
End If
End If
Next
Set x = .Clone
End With
With Sheets("sheet3").Cells(1).Resize(x.Count + 1, UBound(a, 2))
.CurrentRegion.Clear
With .Rows(1)
.Value = a
.Font.Bold = True
End With
Union(.Columns(1), .Columns(4)).NumberFormat = "@"
Union(.Columns("b:c"), .Columns("e")).NumberFormat = _
"_(* #,##0.00_);_(* (#,##0.00);_(* "" - ""??_);_(@_)"
For i = 0 To x.Count - 1
w = x.getbyindex(i)
.Rows(i + 2).Value = x.getbyindex(i)
Next
.Columns(3).Offset(1).Formula = _
"=if(and(rc[-1]<>0,rc[2]<>0),sum(rc[-1],rc[2]),"""")"
.Columns.AutoFit
.Parent.Select
End With
End Sub
Bookmarks