Option Explicit
Sub TongHop2()
Dim sArr(), td(), GoiCuoc, Res(), Res2(), Ma(), sh As Worksheet, Dic As Object, Dic2 As Object, iKey As String
Dim eCol As Long, sCol As Long, eRow As Long, i As Long, j As Long
Dim k As Long, ik As Long, jk As Long, n As Long, q As Long
Set Dic = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
With Sheets("MaHang")
eRow = .Range("B" & Rows.Count).End(xlUp).Row
If eRow > 1 Then
sArr = .Range("B2:C" & eRow).Value
For i = 1 To UBound(sArr)
Dic2.Item(sArr(i, 2)) = sArr(i, 1)
Next i
End If
End With
With Sheets("Tong")
td = .Range("A1:E1").Value
eRow = .Range("E" & Rows.Count).End(xlUp).Row
eCol = .UsedRange.Columns.Count
If eRow > 1 Then .Range("A2:A" & eRow).Resize(, eCol).Clear
End With
Application.ScreenUpdating = False
GoiCuoc = Array("PON", "PAYTV")
For n = 0 To UBound(GoiCuoc)
sCol = 5: k = 1
ReDim Res(1 To 1000, 1 To sCol)
For Each sh In ThisWorkbook.Worksheets
If Not sh.Name Like "T?ng" Then
eRow = sh.Range("F" & Rows.Count).End(xlUp).Row + 1
For i = 2 To eRow - 1
If UCase(sh.Range("A" & i).Value) = GoiCuoc(n) Then
eCol = sh.Cells(i - 1, Columns.Count).End(1).Column
sArr = sh.Range(sh.Cells(i - 1, "A"), sh.Cells(eRow, eCol)).Value
Exit For
End If
Next i
For j = 6 To eCol
iKey = sArr(1, j)
If Dic.exists(iKey) = False Then
sCol = sCol + 1
ReDim Preserve Res(1 To 1000, 1 To sCol)
Res(1, sCol) = iKey
Dic.Add iKey, sCol
End If
Next j
Res(2, 1) = GoiCuoc(n)
For i = 2 To UBound(sArr)
If Len(sArr(i, 3)) = 0 Then Exit For
'iKey = sArr(i, 3) & "#" & sArr(i, 4)
iKey = sArr(i, 4)
If Dic.exists(iKey) = False Then
k = k + 1
Dic.Add iKey, k
Res(k, 2) = k - 1
'Res(k, 3) = sArr(i, 3)
Res(k, 4) = sArr(i, 4)
End If
ik = Dic.Item(iKey)
Res(ik, 5) = Res(ik, 5) + sArr(i, 5)
For j = 6 To eCol
jk = Dic.Item(sArr(1, j))
If sArr(i, j) > 0 Then
Res(ik, jk) = Res(ik, jk) + sArr(i, j)
End If
Next j
Next i
End If
Next
ik = 1
If k > 1 Then
Dic.RemoveAll
ReDim Res2(1 To k + 2, 1 To sCol)
Res2(k + 2, 5) = "Tong Cong"
For j = 6 To sCol
Res2(1, j) = Res(1, j)
Next j
For i = 2 To k
iKey = Res(i, 3)
If Dic.exists(iKey) = False Then
Dic.Add iKey, Empty
For q = i To k
If iKey = Res(q, 3) Then
ik = ik + 1
For j = 1 To sCol
Res2(ik, j) = Res(q, j)
If j > 5 Then Res2(k + 2, j) = Res2(k + 2, j) + Res(ik, j)
Next j
End If
Next q
End If
Next i
With Sheets("Tong")
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 2 Then
eRow = eRow + 2
.Range("A" & eRow).Resize(, 5).Value = td
End If
.Range("A" & eRow + 1).Resize(k + 2, sCol).Value = Res2
.Range("A" & eRow).Resize(k + 3, sCol).Borders.LineStyle = 1
ReDim Res(1 To 1, 1 To sCol - 5)
For j = 6 To sCol
Res(1, j - 5) = Dic2.Item(Res2(1, j))
Next j
.Range("F" & eRow).Resize(, sCol - 5).Value = Res
End With
End If
Dic.RemoveAll
Next n
Application.ScreenUpdating = True
End Sub
