VBA To Concatenate Data

Maybe :

Sub Test()
  Dim a, i As Long, p As Long
  With Sheets("Sheet1")
    With .Range("A2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
      a = .Value
      For i = 1 To UBound(a, 1)
          If Not IsEmpty(a(i, 1)) Then
             p = p + 1
             a(p, 1) = a(i, 1)
             a(p, 2) = a(i, 2)
          Else
             a(p, 2) = a(p, 2) & vbTab & a(i, 2)
          End If
      Next i
      For i = p + 1 To UBound(a, 1)
          a(i, 1) = vbNullString
          a(i, 2) = vbNullString
      Next i
      .Value = a
      .Columns(2).TextToColumns DataType:=xlDelimited, Tab:=True
    End With
  End With
End Sub

Thanks a lot Mr. Karedog for awesome code
As for this part

For i = p + 1 To UBound(a, 1)
          a(i, 1) = vbNullString
          a(i, 2) = vbNullString
      Next i

Instead of looping to remove the rows inside the array. Isn't it easy to use Redim Preserve to slice those rows after p variable .. and if possible can you show us this part?

@jo15765, You are welcome, thanks for marking the thread as solved.

@Yasser,
Thanks for rep.points.
Redim Preserve can only redim the last dimension of an array, in case of 2D array, you can only Redim Preserve to add or delete more columns, but not rows.
And beside, if only we can do this (using transpose, redim preserved, then re-transpose, which won't worked for large array), the result array would be smaller than original range, which means you still have to write more code to clean the "redundant area" at bottom. Hope it's clear.

Thanks a lot my friend. Yes now it is clear.
Thank you very much