Sub demo()
Dim a, b, c
Dim i As Long, j As Long, n As Long, nc As Long, lr As Long
Dim sdate As Long
Application.ScreenUpdating = False
sdate = CLng(Sheets("Output").Cells(2, "A"))
With Sheets("Data")
.Activate
lr = .Cells(Rows.Count, "A").End(xlUp).Row
With ActiveSheet.Sort
.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SortFields.Add Key:=Range("V1"), Order:=xlAscending
.SortFields.Add Key:=Range("D1"), Order:=xlAscending
.SetRange Range("B1:V1" & lr)
.Header = xlYes
End With
a = .Range("A2:V" & Cells(Rows.Count, "A").End(xlUp).Row)
End With
i = 1: n = 0
ReDim b(1 To 3, 1 To 1000)
With CreateObject("scripting.dictionary")
For i = 1 To UBound(a, 1)
txt = a(i, 10)
If Not .Exists(txt) Then
n = n + 1
.Add txt, n
.Item(txt) = n
End If
If a(i, 22) >= sdate Then
If a(i, 4) = "Order" Then
b(2, .Item(txt)) = b(2, .Item(txt)) + a(i, 7)
If i = UBound(a, 1) Then Exit For
If a(i + 1, 4) = "Return" And a(i + 1, 22) >= a(i, 22) Then _
b(1, .Item(txt)) = a(i, 10): b(3, .Item(txt)) = b(3, .Item(txt)) + a(i, 7)
End If
End If
Next i
End With
nc = 0
ReDim c(1 To 3, 1 To n)
For i = 1 To n
If b(1, i) <> "" Then
nc = nc + 1
c(1, nc) = b(1, i): c(2, nc) = b(2, i): c(3, nc) = b(3, i)
End If
Next i
With Sheets("Output")
.[A5].Resize(1, 3) = Array("Customer Number", "Orders", "Returns")
.[a6].Resize(nc, 3) = Application.Transpose(c)
.Activate
End With
Application.ScreenUpdating = True
End Sub
"Data" is sorted and results are on sheet "Output", RUN button for macro
Bookmarks