Option Explicit
Sub GPE()
Dim Ws As Worksheet, Lr As Long, i As Long, k As Long, Lr1 As Long
Dim Arr(), Res(1 To 100000, 1 To 100), j As Long, Res0(1 To 100000, 1 To 3)
Dim l As Long, m As Long, ii As Long, jj As Long
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Lr2 As Long, Arr1(), Lc As Long
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Report").Columns("J:AA").Delete shift:=xlToLeft
For Each Ws In Worksheets
If Ws.Name <> "Report" Then
Lr = Ws.Range("B" & Rows.Count).End(xlUp).Row
Arr = Ws.Range("B3:D" & Lr).Value
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
m = m + 1
For j = 1 To 3
Res0(m, j) = Arr(i, j)
Next j
End If
Next i
End If
Next Ws
With Sheets("Report")
.Range("J3").Resize(m, 3) = Res0
.Range("J3").CurrentRegion.Copy .Range("R3")
Lr2 = .Range("R" & Rows.Count).End(xlUp).Row
Lc = .Cells(2, Columns.Count).End(xlToLeft).Column
Set Rng1 = .Range("R3:R" & Lr2)
Set Rng2 = .Range("S3:S" & Lr2)
Set Rng3 = .Range("T3:T" & Lr2)
.Range("J3:J" & Lr2).RemoveDuplicates Columns:=1, Header:=xlNo
.Range("L3:L" & Lr2).RemoveDuplicates Columns:=1, Header:=xlNo
Lr1 = .Range("J" & Rows.Count).End(xlUp).Row
.Range("L3").Select
.Range(Selection, Selection.End(xlDown)).Copy
.Range("K2").PasteSpecial Transpose:=True
.Range("K3:L10000").ClearContents
Arr1 = .Range("J2").CurrentRegion.Value
For ii = 2 To UBound(Arr1, 1)
For jj = 2 To UBound(Arr1, 2)
Res(ii - 1, jj - 1) = Application.SumIfs(Rng2, Rng1, Arr1(ii, 1), Rng3, Arr1(1, jj))
Next jj
Next ii
.Range("K3").Resize(ii, jj).Value = Res
.Range("K3").CurrentRegion.Borders.LineStyle = 1
.Range("J2") = "ITEM"
.Columns("J:AA").AutoFit
.Range("R3").CurrentRegion.Delete
End With
Application.ScreenUpdating = True
MsgBox "Xong"
End Sub
