Option Explicit
Sub DonSoLieu()
Dim WF, Clls As Range, Rng As Range, sRng As Range, Cls As Range
Dim Col As Byte, Rws As Long, Rw1 As Long
Set Rng = [B2].CurrentRegion
Col = Rng.Find(What:="*", after:=Rng.Cells(1), LookIn:=-4123, Lookat:=xlPart _
, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set WF = Application.WorksheetFunction
For Each Clls In Range([A3], [A65500].End(xlUp))
If Clls.Value <> "Cong PS" Then
Set Rng = Clls.Offset(, 1).Resize(, Col - 1)
Set sRng = Rng.Find("DK", , , xlWhole)
If sRng Is Nothing Then
If WF.CountBlank(Rng) < 4 Then
For Each Cls In Rng
If Cls.Value <> "" And Cls.Column < 4 Then ''
Rw1 = Cls.End(xlUp).Row + 1
Cells(IIf(Rw1 > Rws, Rw1, Rws), Cls.Column).Value = Cls.Value
Cls.Value = ""
ElseIf Cls.Value <> "" And Cls.Column = 4 Then
If WF.CountBlank(Rng.Offset(-1)) = 4 Then _
Rng.Offset(-1).EntireRow.Delete
End If
Next Cls
Else
Rng.Interior.ColorIndex = 38
End If
Else
Rws = sRng.Row + 1
End If
Else
End If
Next Clls
End Sub
