Sub Macros()
Dim Arr, MyArr() As Variant
Dim i As Long, r As Long, n As Long
Arr = ActiveSheet.UsedRange
For i = 1 To UBound(Arr)
     ReDim Preserve MyArr(1 To 4, 0 To n)
     If Arr(i, 1) <> Empty And Arr(i, 2) <> Empty Then
         MyArr(1, n) = Arr(i, 1)
         MyArr(2, n) = Arr(i, 2)
         MyArr(3, n) = Arr(i, 3)
         MyArr(4, n) = Arr(i, 4)
         r = 0
     End If
     If Arr(i, 1) = Empty And Arr(i, 2) <> Empty Then
         MyArr(2, n) = MyArr(2, n) & " " & Arr(i, 2)
     End If
     If Arr(i, 1) = Empty And Arr(i, 2) = Empty And r = 0 Then n = n + 1: r = 1
Next i
ActiveSheet.UsedRange.Clear
ActiveSheet.Range("A1").Resize(n + 1, 4) = Application.Transpose(MyArr)
End Sub