Nhờ sửa code tổng hợp dữ liệu từ nhiều sheet

[TrungChinhs]

Mình có bài tập Tổng hợp dữ liệu từ nhiều sheet chạy bằng VBA rất hay nhưng sheet tổng hợp trình bày các dòng tổng cộng chưa được ưng ý lắm nên nhờ các bạn sửa giúp code trong bài (có file gửi kèm) yêu cầu cụ thể ghi trong sheet tong hợp. Xin Cảm ơn!
,

 

[SA_DQ]

Tranh thủ trước khi lên đường về quê để cháu nó bái tổ

Chú ý trước khi sử dụng:
1*/ Phải lấy trong file đính kèm; Lúc đó mới đảm bảo trật tự tổng hợp theo các sheets như cũ;
Các sheets bạn đưa lên sau này không đúng trật tự quy ước trong excel (Cụ thể 'Khu B' trước 'Khu A' - Điều này thấy rõ, một khi bạn vô CS VBE)
2*/ Chưa kịp thời gian để tu chỉnh, bạn nhờ ai đó sửa, nếu còn sai sót hay chưa vừa í!! Mình còn 3 ngày nữa mới có thể tiếp tục việc này được, mong thông cảm!!

Option Explicit
Sub TongHop2()
Dim Sh As Worksheet, TgHop As Worksheet
 Dim Rng As Range, Clls As Range, SRng As Range, bRng As Range
 Dim Tong As Single:             Dim sAddr As String '<<=='
 Dim bJ As Byte, ERow As Long, lRow As Long
 Dim DaCo As Boolean
 
 Application.ScreenUpdating = False
 Set TgHop = Sheets("Tong Hop")
 TgHop.[it1] = "ChuHo"
1 ' Them Cac Dong Phu Tro Vo Cac Sheet:'
 For Each Sh In Worksheets
   If Sh.Name <> "Tong hop" Then
      Sh.Select:  lRow = [a65500].End(xlUp).Row
      Range("B2:B" & lRow).Copy Destination:=TgHop.Range("IT" & _
         TgHop.[it65500].End(xlUp).Row + 1)
      Columns("A:A").Select
      Selection.SpecialCells(xlCellTypeConstants, 1).Select
      Set Rng = Selection
      For bJ = 1 To 2
         For Each Clls In Rng
            If bJ = 1 Then
               Clls.Offset(1).EntireRow.Insert
            Else
               Clls.Offset(1, 1) = Sh.Name
               Clls.Offset(1, 6) = Clls.Offset(, 6)
            End If
      Next Clls, bJ
   End If
 Next Sh
2 ' Tao Danh Sach Khach Hang Duy Nhat:'
 TgHop.Select:               ERow = [b1].CurrentRegion.Rows.Count
 Range("A2:J" & ERow + 9).Clear:        Columns("IT:IT").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.Delete Shift:=xlUp
 Range("IT:IT").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
   "IV1"), Unique:=True
 Columns("IT:IT").Clear
3 ' Chep Du Lieu Vo Sheets("Tong hop"): '
 lRow = [iV65500].End(xlUp).Row
 For bJ = 2 To lRow    'Chu I bJ Khi Khach Hang Nhieu'
   For Each Sh In Worksheets
      If Sh.Name <> "Tong hop" Then
 
         Set Rng = Sh.Columns("B:B").Find(what:=Cells(bJ, "IV"), LookIn:=xlValues)
         If Not Rng Is Nothing Then
            ERow = Rng.Offset(1).End(xlDown).Row
            If ERow > 65500 Then ERow = Sh.[a65500].End(xlUp).Row + 1
 
            If Tong = 0 Then
               Set SRng = [a65500].End(xlUp).Offset(1, 6)
            Else
               Set bRng = [a65500].End(xlUp).Offset(1, 6)
            End If
            Rng.Offset(, -1).Resize(ERow - Rng.Row, 9).Copy _
               Destination:=[a65500].End(xlUp).Offset(1)
            Tong = Tong + Rng.Offset(, 5)
         End If
 
      End If
   Next Sh
   SRng.Value = Tong:               Tong = 0
   bRng.Value = ""
 Next bJ
 
4 ' Xoa Cac Dong Phu Tro:'
 For Each Sh In Worksheets
   If Sh.Name <> "Tong hop" Then
      Do
      Set Rng = Sh.Columns("B:B").Find(what:=Sh.Name, LookIn:=xlValues)
         If Rng Is Nothing Then
            Exit Do
         Else
            Rng.EntireRow.Delete
         End If
      Loop
   End If
 Next Sh
5  ' Xoa Dong Du Tai "Tong hop"'
 Set SRng = Nothing:          ERow = TgHop.[a65500].End(xlUp).Row
 For bJ = 2 To lRow
   For Each Clls In TgHop.Range([B2], Cells(ERow, 2))
      If Clls.Value = Cells(bJ, "iV") Then
         If Not DaCo Then
            DaCo = True
         Else
            If SRng Is Nothing Then
               Set SRng = Clls
            Else
               Set SRng = Union(SRng, Clls)
            End If
         End If
      End If
   Next Clls
   DaCo = False
 Next bJ
 SRng.EntireRow.Delete
 Columns("IV:Iv").Clear   '<<=='
End Sub