Option Explicit
Sub THop()
Dim Sh As Worksheet, Cls As Range, Rng As Range, sRng As Range, Rg0 As Range, Cll As Range
Dim ShName As String
Dim J As Byte, Tmr As Double
Sheets("TongHop").Select: Tmr = Timer()
[b5].CurrentRegion.Offset(1).EntireRow.Delete
Application.ScreenUpdating = False
For Each Cls In Range("AA1:AA3")
With [B65500].End(xlUp).Offset(1)
Cls.Offset(, 1).Resize(, 11).Copy Destination:=.Offset(0)
.Offset(1, -1).Value = 1
End With
For J = 1 To 12
ShName = "t" & Right("0" & CStr(J), 2)
Set Sh = ThisWorkbook.Worksheets(ShName)
Sh.[Am2].Value = Cls.Value
Sh.[A4].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sh.Range( _
"AM1:AM2"), CopyToRange:=Sh.Range("AA3:AJ3"), Unique:=False
Set Rng = Sh.[AB4].CurrentRegion
If Rng.Rows.Count > 1 Then
Rng.Offset(1).Copy Destination:=[B65500].End(xlUp).Offset(1)
End If
Next J
Next Cls
Set Rng = Range([A4], [B65500].End(xlUp).Offset(, -1))
Set sRng = Rng.Find(1, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
ShName = sRng.Address
Do
Set Cll = sRng.End(xlDown).Offset(-2)
If Cll.Row > 65500 Then Set Cll = [B65500].End(xlUp).Offset(, -1)
Set Rg0 = Range(sRng.Offset(1), Cll)
For Each Cls In Rg0
Cls.Value = Cls.Offset(-1).Value + 1
Next Cls
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> ShName
End If
Application.ScreenUpdating = True
[L1].Value = Timer() - Tmr
End Sub
