Sub TongHop(Num As Byte)
Dim J As Long, Rws As Long, W As Byte, Dg As Integer, Tmr As Double
Dim ShName As String, fAdd As String
Dim Sh As Worksheet, Rng As Range, sRng As Range, Rg0 As Range
On Error GoTo LoiCT
Rws = [E65500].End(xlUp).Row
If Num < 2 Then [f3].Resize(Rws, 120).ClearContents
[f3].Resize(Rws, 120).Interior.ColorIndex = 0
Application.ScreenUpdating = False: Tmr = Timer()
For J = 3 To Rws Step 4
For W = 1 To 19
If Num = 1 Then
ShName = "M" & Choose(W, "1", "10", "11", "16", "17", "18", "26", "31", "33", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44")
ElseIf Num = 2 Then
ShName = "M" & Choose(W, "47", "48", "49", "50", "51", "52", "53", "54", "55", "56", "57", "58", "59", "60", "62", "63", "64", "65", "67")
ElseIf Num = 3 Then
ShName = "M" & Choose(W, "68", "69", "70", "71", "72", "73", "74", "75", "76", "77", "78", "79", "80", "81", "82", "83", "45", "66", "")
End If
4 If ShName = "M" Then Exit Sub
5 Set Sh = ThisWorkbook.Worksheets(ShName)
6 Set Rng = Sh.Range(Sh.[G5], Sh.[G9999].End(xlUp))
If Cells(J, "D").Value <> "" Then
Set sRng = Rng.Find(Cells(J, "D").Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
fAdd = sRng.Address
Do
With Cells(J, "E").Offset(, sRng.Row - 6)
.Orientation = 90
.Value = sRng.Offset(, 2).Value
For Dg = 0 To 94
If Dg > 0 And sRng.Offset(Dg).Value <> "" Then Exit For
.Offset(1, Dg).Value = Sh.Cells(sRng.Row + Dg, "R").Value
Next Dg
.Offset(2) = Mid(ShName, 2, 2)
' .Interior.ColorIndex = 34 + (Dg \ 9)'
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> fAdd
End If
End If
Next W
Next J
Application.ScreenUpdating = True
Cells(Num, "A").Value = Timer() - Tmr
Err_: Exit Sub
LoiCT:
MsgBox ShName, , Erl
Resume Err_
End Sub
, Cảm ơn Thầy ạ!
