Sub ChuyenDonGia()
Dim Rws As Long, Col As Byte
Dim MaH As String, Dz As String
Const Alf As String = "C) P) NC AY"
Dim Sh As Worksheet, Rng As Range, sRng As Range, Arr()
Sheets("PTDG").Select
Rws = [d6].CurrentRegion.Rows.Count + 9
ReDim Arr(1 To 1, 1 To 5)
For j = 6 To Rws 'Duyet Tù Dòng Thú 6'
With Cells(j, "B")
If .Value <> "" Then
If j = 6 Then
ElseIf j > 6 Then
Set Sh = ThisWorkbook.Worksheets("DGCT")
Set Rng = Sh.[B4].Resize(Rws)
Set sRng = Rng.Find(MaH, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
sRng.Offset(, 4).Resize(, 4).Value = Arr()
End If
Set Sh = ThisWorkbook.Worksheets("DGTH")
Set Rng = Sh.[B4].Resize(Rws)
Set sRng = Rng.Find(MaH, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
sRng.Offset(, 4).Value = Arr(1, 5)
End If
End If
MaH = Cells(j, "B").Value
ElseIf .Value = "" And .Offset(, 1).Value = "" Then
Dz = Right(RTrim$(.Offset(, 2).Value), 2)
If InStr(Alf, Dz) And Dz <> "" Then
Col = Switch(Dz = "C)", 1, Dz = "P)", 2, Dz = "NC", 3, Dz = "AY", 4)
Arr(1, Col) = Cells(j, "H").Value
Else
Dz = Right(RTrim$(.Offset(, 2).Value), 3)
If Left(Dz, 1) = "h" And Right(Dz, 1) = "p" Then
Arr(1, 5) = Cells(j, "H").Value
End If
End If
End If
End With
Set Sh = ThisWorkbook.Worksheets("DGCT")
Set Rng = Sh.[B4].Resize(Rws)
Set sRng = Rng.Find(MaH, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
sRng.Offset(, 4).Resize(, 4).Value = Arr()
End If
Set Sh = ThisWorkbook.Worksheets("DGTH")
Set Rng = Sh.[B4].Resize(Rws)
Set sRng = Rng.Find(MaH, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
sRng.Offset(, 4).Value = Arr(1, 5)
End If
Next j
End Sub