Here the result go to sheet Result
Sub PartCount()
Dim fr As Long, lr As Long, at As Long, j As Long, i As Long, mr As Range
With Sheets("Point Count")
With .Range("A:A")
fr = .Find("QTY").Row
lr = .Cells(Rows.Count, "A").End(xlUp).Row
End With
at = Application.CountA(.Range("A" & fr + 1, "A" & lr))
ReDim arr(1 To at, 1 To 3)
For i = fr + 1 To lr
If .Cells(i, 1) <> "" Then
j = j + 1
arr(j, 1) = .Cells(i, "A")
arr(j, 2) = .Cells(i, "AH")
arr(j, 3) = Application.SumIfs(.Range("A" & fr + 1, "A" & lr), .Range("AH" & fr + 1, "AH" & lr), .Range("AH" & i))
End If
Next
With Sheets("Result")
.Range("A1").CurrentRegion.ClearContents
.Range("A2").Resize(j, 3) = arr
.Range("A1").Resize(, 2) = Array("QTY", "Part Number")
.Range("C2", "C" & at + 1).Copy .Range("A2")
.Range("C2", "C" & at + 1).ClearContents
Set mr = .Range("A1").CurrentRegion
mr.Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlYes
mr.RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
mr.Columns.AutoFit
End With
End With
End Sub
Kind regards
Leo
Bookmarks