Option Explicit
Sub TachNhieuCot()
Dim lRw As Long
Dim Rng As Range, Clls As Range, uRng As Range, sRng As Range
Dim MyAdd As String
Sheets("CSDL").Select: lRw = [e65500].End(xlUp).Row
Set Rng = Range("E1:E" & lRw): Range("G1:Z" & lRw).Clear
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[H1], Unique:=True
Set uRng = Range("H2:H" & [h65500].End(xlUp).Row)
For Each Clls In uRng
Set sRng = Rng.Find(what:=Clls, LookIn:=xlFormulas, lookat:=xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
sRng.Offset(, Clls.Row + 3) = sRng.Value
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Next Clls
Columns("G:H").Delete Shift:=xlToLeft
End Sub
