Option Explicit
Const SoDg As Byte = 10
Sub TaoLich()
Dim r_Ma As Range, sRng As Range, Tuan As Range, Clls As Range, Rng As Range
Dim eRw As Long, Zw As Long
Dim Sh As Worksheet: Dim MyAdd As String
Sheets("Lich").Select: eRw = [d65500].End(xlUp).Row + 1
Set Rng = Range([C2], Cells(eRw, "C"))
Set Sh = Sheets("S0")
Set r_Ma = Sh.Range("A2:A" & Sh.[A65500].End(xlUp).Row)
Cells(eRw, "A").Resize(2, 9).Value = Cells(eRw - SoDg, "A").Resize(2, 9).Value
For Zw = 1 To 3
1 'Tim Theo Tuan:'
Set sRng = r_Ma.Offset(, 2).Find(Zw, , xlValues, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
If Tuan Is Nothing Then
Set Tuan = sRng.Offset(, -2)
Else
Set Tuan = Union(sRng.Offset(, -2), Tuan)
End If
Set sRng = r_Ma.Offset(, 2).FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
2 ' Tim Trong "Lich":'
Set sRng = Nothing
For Each Clls In Tuan
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
Set sRng = Rng.FindPrevious(sRng)
If Zw = 1 And (eRw - sRng.Row) < 10 Then
With [d65500].End(xlUp)
.Offset(1, -1) = sRng.Value
.Offset(1).Value = sRng.Offset(, 1).Value
.Offset(1, 1).Value = TangSo(sRng.Offset(, 2).Value)
End With
ElseIf Zw = 2 And (eRw - sRng.Row >= 10 And eRw - sRng.Row < 20) Then
With [d65500].End(xlUp)
.Offset(1, -1) = sRng.Value
.Offset(1).Value = sRng.Offset(, 1).Value
If sRng.Value <> "KOR" Then
.Offset(1, 1).Value = TangSo(sRng.Offset(, 2).Value, 1)
Else
.Offset(1, 1).Value = Left(sRng.Offset(, 2), 3) & _
CStr(CInt(Mid(sRng.Offset(, 2), 4) + 2))
End If
End With
ElseIf Zw = 3 And (eRw - sRng.Row >= 20 And eRw - sRng.Row < 30) Then
With [d65500].End(xlUp)
.Offset(1, -1) = sRng.Value
.Offset(1).Value = sRng.Offset(, 1).Value
.Offset(1, 1).Value = TangSo(sRng.Offset(, 2).Value, 2) '8'
End With
End If
End If
Next Clls
Set Tuan = Nothing: Set sRng = Nothing
Next Zw
End Sub
