Option Explicit
Sub TongHop()
Dim Sh As Worksheet
Dim Rng As Range, Clls As Range, SRng As Range, bRng As Range
Dim Tong As Single
Dim bJ As Byte, DgCuoi As Long, Lrow As Long
Application.ScreenUpdating = False
Sheets("Tong Hop").[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:=Sheets("Tong hop").Range("IT" & _
Sheets("Tong Hop").[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:'
Sheets("Tong hop").Select: DgCuoi = [b1].CurrentRegion.Rows.Count
Range("A2:J" & DgCuoi + 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
DgCuoi = Rng.Offset(1).End(xlDown).Row
If DgCuoi > 65500 Then DgCuoi = 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(DgCuoi - 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
Columns("IV:Iv").Clear
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
End Sub
