Hi Please try this...

Sub testing()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim rng As Range
Dim cel As Range
Dim sh As Worksheet
Dim rcount As Long, rocount As Long

Set sh = ThisWorkbook.Sheets(1)
rcount = sh.UsedRange.Rows.Count
Set rng = sh.Range("D1:H" & rcount)

k = 1
For Each cel In rng
If cel <> "" Then
cel.Copy Destination:=sh.Range("R" & k)
k = k + 1
End If
Next cel

sh.Range("r:r").RemoveDuplicates Columns:=1, Header:=xlNo
rocount = sh.Cells(Rows.Count, "R").End(xlUp).Row
mcount = rcount + 5
For m = 6 To rocount

If VBA.Len(sh.Cells(m, "R")) = 8 Then
U = sh.Cells(m, "R")
For Each cel In rng
If cel <> "" And cel = U Then
cel.EntireRow.Copy Destination:=sh.Range("A" & mcount)
mcount = mcount + 1
End If
Next cel
End If

Next m
sh.Range("A2:m" & rcount + 4).EntireRow.Delete
sh.Range("R:R").EntireColumn.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done", vbInformation

End Sub

Thanks & regards,
Vikas