Private Sub Worksheet_Activate()
Dim Dic, sh As Worksheet, iRow As Long, i As Long, j As Long
Dim Arr(), TmpArr
Application.ScreenUpdating = False
On Error Resume Next
Sheet5.Range("A5:F60000").ClearContents
With CreateObject("Scripting.Dictionary")
For Each sh In Worksheets
If sh.Name <> Sheet5 Then
TmpArr = sh.Range(sh.[c5], sh.[C65536].End(xlUp)).Resize(, 4).Value
For iRow = 1 To UBound(TmpArr, 1)
If Not IsEmpty(TmpArr(iRow, 1)) Then
If Not .Exists(TmpArr(iRow, 1)) Then
i = i + 1
.Add TmpArr(iRow, 1), i
ReDim Preserve Arr(1 To 4, 1 To i)
For j = 1 To 4
Arr(j, i) = TmpArr(iRow, j)
Next
Else
Arr(3, .Item(TmpArr(iRow, 1))) = Arr(3, .Item(TmpArr(iRow, 1))) + TmpArr(iRow, 3)
Arr(4, .Item(TmpArr(iRow, 1))) = Arr(4, .Item(TmpArr(iRow, 1))) + TmpArr(iRow, 4)
End If
End If
Next
End If
Next
End With
Sheet5.Range("C5").Resize(i, 4) = WorksheetFunction.Transpose(Arr)
Range("B5:B" & [C65536].End(xlUp).Row).Value = Evaluate("ROW(R:R)")
With Sheet5
ER = Sheet5.[C50000].End(xlUp).Row
.Range(Rows(ER), .Rows(65536)).ClearContents
End With
End Sub
