Sub tt()
     Application.ScreenUpdating = 0
     r1_ = UsedRange.Rows.Count
     For i = r1_ To 5 Step -1
         ti_ = Range("D" & i)
         If ti_ <> "" Then
             t_ = ti_ & " " & t_
             If Range("B" & i) <> "" Then
                 Range("D" & i) = t_
                 t_ = ""
             Else
                 If WorksheetFunction.CountA(Range(i & ":" & i)) = 1 Then
                     Rows(i).Delete
                 Else
                     Range("D" & i).ClearContents
                 End If
             End If
         End If
     Next i
     Range("B5:B" & r1_).Copy
     Range("D5:K" & r1_).PasteSpecial Paste:=xlPasteFormats
     Application.CutCopyMode = False
     Range("G5:I" & r1_).UnMerge
     Range("A1").Select
     Application.ScreenUpdating = 1
End Sub