Giúp em Code VBA chạy tập hợp tổng số lượng mã hàng theo từng loại hình? (3 người xem)

[HieuCD]

Dạ, Tổng số lượng các vật tư theo từng loại hình không đúng rồi anh ạ

Khong dung nhu the nao? cho vi du cu the

 

[danhculao]

Khong dung nhu the nao? cho vi du cu the

Dạ, cho kết quả ở sheet Tong như sau ạ:

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019030​

20025279​

20022152​

20024516​

20019586​

20032853​

20018431​

20023533​

20026837​

20018166​

20021317​

1 core(MET)

G-97RG3(CHI)

FC G(CHI)

Day rut(SOI)

GPON Wifi(CHI)

Archer C5(BO)

EPON Wifi(CHI)

G-97D2(CHI)

ONT 1 port 1G(CHI)

FC E(CHI)

Vigor 2925(CAI)

PON

1​

Triển khai mới

7​

769​

7​

14​

66​

2​

Chuyển địa điểm

6​

78​

4​

8​

36​

3​

Khác

5​

15​

1​

0​

45​

Tong Cong

862​

12​

22​

147​

0​

0​

0​

0​

0​

0​

0​

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019319​

20021783​

20000314​

20020106​

20016788​

20031607​

20020534​

20000112​

AV(SOI)

Nguon HDBox(CAI)

RJ45(CHI)

Remote HDBox(CHI)

HDMI(CAI)

Box 4K(CHI)

HD box Old(CHI)

Cap 5(MET)

PAYTV

1​

Khác

5​

0​

5​

8​

5​

5​

5​

0​

50​

2​

Chuyển địa điểm

7​

3​

7​

18​

7​

4​

3​

4​

30​

3​

Triển khai mới

6​

6​

6​

31​

6​

0​

6​

0​

60​

Tong Cong

9​

18​

57​

18​

9​

14​

4​

140​

 

[Ba Tê]

Dạ, cho kết quả ở sheet Tong như sau ạ:

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019030​

20025279​

20022152​

20024516​

20019586​

20032853​

20018431​

20023533​

20026837​

20018166​

20021317​

1 core(MET)

G-97RG3(CHI)

FC G(CHI)

Day rut(SOI)

GPON Wifi(CHI)

Archer C5(BO)

EPON Wifi(CHI)

G-97D2(CHI)

ONT 1 port 1G(CHI)

FC E(CHI)

Vigor 2925(CAI)

PON

1​

Triển khai mới

7​

769​

7​

14​

66​

2​

Chuyển địa điểm

6​

78​

4​

8​

36​

3​

Khác

5​

15​

1​

0​

45​

Tong Cong

862​

12​

22​

147​

0​

0​

0​

0​

0​

0​

0​

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019319​

20021783​

20000314​

20020106​

20016788​

20031607​

20020534​

20000112​

AV(SOI)

Nguon HDBox(CAI)

RJ45(CHI)

Remote HDBox(CHI)

HDMI(CAI)

Box 4K(CHI)

HD box Old(CHI)

Cap 5(MET)

PAYTV

1​

Khác

5​

0​

5​

8​

5​

5​

5​

0​

50​

2​

Chuyển địa điểm

7​

3​

7​

18​

7​

4​

3​

4​

30​

3​

Triển khai mới

6​

6​

6​

31​

6​

0​

6​

0​

60​

Tong Cong

9​

18​

57​

18​

9​

14​

4​

140​

Thử xem file này, dữ liệu lu bu quá nên viết thành 2 Sub.

 

[HieuCD]

Dạ, cho kết quả ở sheet Tong như sau ạ:

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019030​

20025279​

20022152​

20024516​

20019586​

20032853​

20018431​

20023533​

20026837​

20018166​

20021317​

1 core(MET)

G-97RG3(CHI)

FC G(CHI)

Day rut(SOI)

GPON Wifi(CHI)

Archer C5(BO)

EPON Wifi(CHI)

G-97D2(CHI)

ONT 1 port 1G(CHI)

FC E(CHI)

Vigor 2925(CAI)

PON

1​

Triển khai mới

7​

769​

7​

14​

66​

2​

Chuyển địa điểm

6​

78​

4​

8​

36​

3​

Khác

5​

15​

1​

0​

45​

Tong Cong

862​

12​

22​

147​

0​

0​

0​

0​

0​

0​

0​

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019319​

20021783​

20000314​

20020106​

20016788​

20031607​

20020534​

20000112​

AV(SOI)

Nguon HDBox(CAI)

RJ45(CHI)

Remote HDBox(CHI)

HDMI(CAI)

Box 4K(CHI)

HD box Old(CHI)

Cap 5(MET)

PAYTV

1​

Khác

5​

0​

5​

8​

5​

5​

5​

0​

50​

2​

Chuyển địa điểm

7​

3​

7​

18​

7​

4​

3​

4​

30​

3​

Triển khai mới

6​

6​

6​

31​

6​

0​

6​

0​

60​

Tong Cong

9​

18​

57​

18​

9​

14​

4​

140​

Chinh lai code

Sub TongHop()
  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(, 200).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)
    Res(2, 1) = GoiCuoc(n)
    For Each sh In ThisWorkbook.Worksheets
      If sh.Name Like "Tab*" Then
        eRow = sh.Range("F" & Rows.Count).End(xlUp).Row + 1
        If eRow > 2 Then
          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
              ReDim Preserve Res2(1 To 1, 1 To sCol - 5)
              Res2(1, sCol - 5) = Dic2.Item(iKey)
            End If
          Next j
        
          For i = 2 To UBound(sArr)
            If Len(sArr(i, 3)) = 0 Then
              Exit For
            End If
            iKey = sArr(i, 4)
            If Dic.exists(iKey) = False Then
              k = k + 1
              Dic.Add iKey, k
              Res(k, 2) = k - 1
              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
      End If
    Next
    ik = 1
    If k > 1 Then
      For i = 2 To k
        For j = 6 To eCol
          If Res(i, j) > 0 Then
              Res(k + 2, j) = Res(k + 2, j) + Res(i, j)
          End If
        Next j
      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
        Res(k + 2, 5) = "Tong Cong"
        .Range("A" & eRow + 1).Resize(k + 2, sCol).Value = Res
        .Range("A" & eRow).Resize(k + 3, sCol).Borders.LineStyle = 1
        .Range("F" & eRow).Resize(, sCol - 5).Value = Res2
      End With
    End If
    Dic.RemoveAll
  Next n
  Application.ScreenUpdating = True
End Sub

 

[danhculao]

Thử xem file này, dữ liệu lu bu quá nên viết thành 2 Sub.

Dạ, em cám ơn nhiều ạ

Bài đã được tự động gộp: 13/7/19

Chinh lai code

Sub TongHop()
  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(, 200).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)
    Res(2, 1) = GoiCuoc(n)
    For Each sh In ThisWorkbook.Worksheets
      If sh.Name Like "Tab*" Then
        eRow = sh.Range("F" & Rows.Count).End(xlUp).Row + 1
        If eRow > 2 Then
          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
              ReDim Preserve Res2(1 To 1, 1 To sCol - 5)
              Res2(1, sCol - 5) = Dic2.Item(iKey)
            End If
          Next j
       
          For i = 2 To UBound(sArr)
            If Len(sArr(i, 3)) = 0 Then
              Exit For
            End If
            iKey = sArr(i, 4)
            If Dic.exists(iKey) = False Then
              k = k + 1
              Dic.Add iKey, k
              Res(k, 2) = k - 1
              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
      End If
    Next
    ik = 1
    If k > 1 Then
      For i = 2 To k
        For j = 6 To eCol
          If Res(i, j) > 0 Then
              Res(k + 2, j) = Res(k + 2, j) + Res(i, j)
          End If
        Next j
      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
        Res(k + 2, 5) = "Tong Cong"
        .Range("A" & eRow + 1).Resize(k + 2, sCol).Value = Res
        .Range("A" & eRow).Resize(k + 3, sCol).Borders.LineStyle = 1
        .Range("F" & eRow).Resize(, sCol - 5).Value = Res2
      End With
    End If
    Dic.RemoveAll
  Next n
  Application.ScreenUpdating = True
End Sub

Dạ, em cám ơn nhiều ạ

 

[danhculao]

Thử xem file này, dữ liệu lu bu quá nên viết thành 2 Sub.

Dạ, sheet Tong kết quả tổng vẫn chưa đúng anh ạ. Do trường hợp Tab2 chỉ có 1 bảng là PON và Tab3 chỉ có 1 bảng là PayTV nên dữ liệu bên sheet Tong link qua không hiểu. Nhờ anh giúp lại em Code với ạ. Em cám ơn!

 

[danhculao]

Chinh lai code

Sub TongHop()
  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(, 200).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)
    Res(2, 1) = GoiCuoc(n)
    For Each sh In ThisWorkbook.Worksheets
      If sh.Name Like "Tab*" Then
        eRow = sh.Range("F" & Rows.Count).End(xlUp).Row + 1
        If eRow > 2 Then
          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
              ReDim Preserve Res2(1 To 1, 1 To sCol - 5)
              Res2(1, sCol - 5) = Dic2.Item(iKey)
            End If
          Next j
       
          For i = 2 To UBound(sArr)
            If Len(sArr(i, 3)) = 0 Then
              Exit For
            End If
            iKey = sArr(i, 4)
            If Dic.exists(iKey) = False Then
              k = k + 1
              Dic.Add iKey, k
              Res(k, 2) = k - 1
              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
      End If
    Next
    ik = 1
    If k > 1 Then
      For i = 2 To k
        For j = 6 To eCol
          If Res(i, j) > 0 Then
              Res(k + 2, j) = Res(k + 2, j) + Res(i, j)
          End If
        Next j
      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
        Res(k + 2, 5) = "Tong Cong"
        .Range("A" & eRow + 1).Resize(k + 2, sCol).Value = Res
        .Range("A" & eRow).Resize(k + 3, sCol).Borders.LineStyle = 1
        .Range("F" & eRow).Resize(, sCol - 5).Value = Res2
      End With
    End If
    Dic.RemoveAll
  Next n
  Application.ScreenUpdating = True
End Sub

Dạ, sheet Tong kết quả vẫn chưa đúng anh ạ, Nhờ anh giúp lại em với ạ
Kết quả đúng như bảng dưới:

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019030​

20025279​

20022152​

20024516​

20024739​

1 core(MET)

G-97RG3(CHI)

FC G(CHI)

Day rut(SOI)

TL-WR841ND(CHI)

PON

1​

Triển khai mới

5​

644​

5​

10​

46​

125​

2​

Chuyển địa điểm

4​

58​

3​

6​

27​

0​

3​

Khác

3​

15​

0​

0​

27​

250​

Tong Cong

717​

8​

16​

100​

375​

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019319​

20021783​

20000314​

20020106​

20016788​

20031607​

20020534​

20000112​

AV(SOI)

Nguon HDBox(CAI)

RJ45(CHI)

Remote HDBox(CHI)

HDMI(CAI)

Box 4K(CHI)

HD box Old(CHI)

Cap 5(MET)

PAYTV

1​

Khác

5​

0​

5​

8​

5​

5​

5​

0​

83​

2​

Chuyển địa điểm

7​

3​

7​

18​

7​

4​

3​

4​

30​

3​

Triển khai mới

6​

6​

6​

31​

6​

0​

6​

0​

60​

Tong Cong

9​

18​

57​

18​

9​

14​

4​

173​

 

[HieuCD]

Dạ, sheet Tong kết quả vẫn chưa đúng anh ạ, Nhờ anh giúp lại em với ạ
Kết quả đúng như bảng dưới:

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019030​

20025279​

20022152​

20024516​

20024739​

1 core(MET)

G-97RG3(CHI)

FC G(CHI)

Day rut(SOI)

TL-WR841ND(CHI)

PON

1​

Triển khai mới

5​

644​

5​

10​

46​

125​

2​

Chuyển địa điểm

4​

58​

3​

6​

27​

0​

3​

Khác

3​

15​

0​

0​

27​

250​

Tong Cong

717​

8​

16​

100​

375​

Gói cước

STT

Quận

Loại hình

Số lượng HĐ

20019319​

20021783​

20000314​

20020106​

20016788​

20031607​

20020534​

20000112​

AV(SOI)

Nguon HDBox(CAI)

RJ45(CHI)

Remote HDBox(CHI)

HDMI(CAI)

Box 4K(CHI)

HD box Old(CHI)

Cap 5(MET)

PAYTV

1​

Khác

5​

0​

5​

8​

5​

5​

5​

0​

83​

2​

Chuyển địa điểm

7​

3​

7​

18​

7​

4​

3​

4​

30​

3​

Triển khai mới

6​

6​

6​

31​

6​

0​

6​

0​

60​

Tong Cong

9​

18​

57​

18​

9​

14​

4​

173​

Chỉnh lại

Sub TongHop()
  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
    .Range("F1").Resize(, 200).Clear
    If eRow > 1 Then .Range("A2:A" & eRow).Resize(, 200).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)
    Res(2, 1) = GoiCuoc(n)
    For Each sh In ThisWorkbook.Worksheets
      If sh.Name Like "Tab*" Then
        eRow = sh.Range("F" & Rows.Count).End(xlUp).Row + 1
        If eRow > 2 Then
          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
          If i < eRow Then
            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
                ReDim Preserve Res2(1 To 1, 1 To sCol - 5)
                Res2(1, sCol - 5) = Dic2.Item(iKey)
              End If
            Next j
        
            For i = 2 To UBound(sArr)
              If Len(sArr(i, 3)) = 0 Then
                Exit For
              End If
              iKey = sArr(i, 4)
              If Dic.exists(iKey) = False Then
                k = k + 1
                Dic.Add iKey, k
                Res(k, 2) = k - 1
                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
        End If
      End If
    Next
    ik = 1
    If k > 1 Then
      For i = 2 To k
        For j = 6 To sCol
          If Res(i, j) > 0 Then
              Res(k + 2, j) = Res(k + 2, j) + Res(i, j)
          End If
        Next j
      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
        Res(k + 2, 5) = "Tong Cong"
        .Range("A" & eRow + 1).Resize(k + 2, sCol).Value = Res
        .Range("A" & eRow).Resize(k + 3, sCol).Borders.LineStyle = 1
        .Range("F" & eRow).Resize(, sCol - 5).Value = Res2
      End With
    End If
    Dic.RemoveAll
  Next n
  Application.ScreenUpdating = True
End Sub

 

[danhculao]

Chỉnh lại

Sub TongHop()
  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
    .Range("F1").Resize(, 200).Clear
    If eRow > 1 Then .Range("A2:A" & eRow).Resize(, 200).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)
    Res(2, 1) = GoiCuoc(n)
    For Each sh In ThisWorkbook.Worksheets
      If sh.Name Like "Tab*" Then
        eRow = sh.Range("F" & Rows.Count).End(xlUp).Row + 1
        If eRow > 2 Then
          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
          If i < eRow Then
            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
                ReDim Preserve Res2(1 To 1, 1 To sCol - 5)
                Res2(1, sCol - 5) = Dic2.Item(iKey)
              End If
            Next j
       
            For i = 2 To UBound(sArr)
              If Len(sArr(i, 3)) = 0 Then
                Exit For
              End If
              iKey = sArr(i, 4)
              If Dic.exists(iKey) = False Then
                k = k + 1
                Dic.Add iKey, k
                Res(k, 2) = k - 1
                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
        End If
      End If
    Next
    ik = 1
    If k > 1 Then
      For i = 2 To k
        For j = 6 To sCol
          If Res(i, j) > 0 Then
              Res(k + 2, j) = Res(k + 2, j) + Res(i, j)
          End If
        Next j
      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
        Res(k + 2, 5) = "Tong Cong"
        .Range("A" & eRow + 1).Resize(k + 2, sCol).Value = Res
        .Range("A" & eRow).Resize(k + 3, sCol).Borders.LineStyle = 1
        .Range("F" & eRow).Resize(, sCol - 5).Value = Res2
      End With
    End If
    Dic.RemoveAll
  Next n
  Application.ScreenUpdating = True
End Sub

Em cám ơn nhiều ạ!