Sub SummaryData(ByVal Target As Range, ByVal Sum_Range As Range, _
ByVal Criteria_Range1 As Range, Criteria1, _
ByVal Criteria_Range2 As Range, Criteria2, _
ByVal SummaryData1 As Range, ByVal SummaryData2 As Range)
Dim aRes()
Dim dic1 As Object
Dim dic2 As Object
Dim aCriteria1
Dim aCriteria2
Dim aSum
Dim aData1
Dim aData2
Dim sData1
Dim sData2
Dim sCriteria1
Dim sCriteria2
Dim lRow As Long
Dim lCol As Long
Dim lRowCount As Long
Dim idx As Long
Dim p1 As Long, p2 As Long, ub As Long
Dim dSum As Double
On Error Resume Next
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
aSum = Sum_Range.Value
aCriteria1 = Criteria_Range1.Value
aCriteria2 = Criteria_Range2.Value
aData1 = SummaryData1.Value
aData2 = SummaryData2.Value
lRowCount = UBound(aData1, 1)
ReDim aRes(1 To lRowCount, 1 To 1)
ReDim tmpSum(1 To lRowCount, 1 To 1)
ReDim tmpCount(1 To lRowCount, 1 To 1)
lRow = 1: lCol = 1
For idx = 1 To lRowCount
If aData1(idx, 1) <> Empty Then
If aData2(idx, 1) <> Empty Then
sData1 = aData1(idx, 1)
sData2 = aData2(idx, 1)
sCriteria1 = aCriteria1(idx, 1)
sCriteria2 = aCriteria2(idx, 1)
dSum = CDbl(aSum(idx, 1))
If sCriteria1 = Criteria1 Then
If sCriteria2 = Criteria2 Then
If Not dic1.Exists(sData1) Then
lRow = lRow + 1
dic1.Add sData1, lRow
aRes(lRow, 1) = sData1
End If
If Not dic2.Exists(sData2) Then
lCol = lCol + 1
dic2.Add sData2, lCol
ReDim Preserve aRes(1 To lRowCount, 1 To lCol)
aRes(1, lCol) = sData2
End If
p1 = dic1.Item(sData1): p2 = dic2.Item(sData2)
aRes(p1, p2) = CDbl(aRes(p1, p2)) + dSum
End If
End If
End If
End If
Next
Target.Resize(lRow, lCol).Value = aRes
End Sub
Sub Main()
Dim wksSrc As Worksheet
Dim wksDes As Worksheet
Dim Target As Range
Dim Sum_Range As Range
Dim Criteria_Range1 As Range
Dim Criteria_Range2 As Range
Dim Criteria1
Dim Criteria2
Dim SummaryData1 As Range
Dim SummaryData2 As Range
Set wksSrc = Worksheets("Data")
Set wksDes = Worksheets("Test2")
Set Target = wksDes.Range("A4")
Set Sum_Range = wksSrc.Range("G2:G100000")
Set Criteria_Range1 = wksSrc.Range("E2:E100000")
Set Criteria_Range2 = wksSrc.Range("D2:D100000")
Criteria1 = wksDes.Range("G2").Value
Criteria2 = wksDes.Range("F2").Value
Set SummaryData1 = wksSrc.Range("A2:A100000")
Set SummaryData2 = wksSrc.Range("C2:C100000")
On Error Resume Next
Target.CurrentRegion.ClearContents
Application.ScreenUpdating = False
SummaryData Target, Sum_Range, Criteria_Range1, Criteria1, Criteria_Range2, Criteria2, SummaryData1, SummaryData2
With Target.CurrentRegion.Offset(, 1)
.Sort .Rows(1), xlAscending, , , , , , , xlNo, , , xlLeftToRight
End With
Application.ScreenUpdating = True
End Sub
