Combine text from multiple sequential rows by column to the left

Try using this code to accomplish your task (I have commented for better understanding).  The code works using your example data:

Sub Test()

Dim Lrow As Long
Dim LngLp As Long
Dim TXT As String
Dim Flag As Boolean

'Supress Pop Up Alerts
Application.DisplayAlerts = False

'Define Last Row based on column B
Lrow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
1
'UnMerge All Cells
ActiveSheet.Cells.UnMerge

'Loop through Values
For LngLp = 1 To Lrow
    If ActiveSheet.Cells(LngLp, "A") <> "" Then 'Test for value
       If Flag = True Then
            ActiveSheet.Range(Cells(Counter, "B"), Cells(LngLp - 1, "B")).Merge 'Merge Cells
            ActiveSheet.Range(Cells(Counter, "A"), Cells(LngLp - 1, "A")).Merge 'Merge Cells
            ActiveSheet.Cells(Counter, "B") = Mid(TXT, 1, Len(TXT) - 1) 'Chop of Extra Space
            LngLp = LngLp - 1 'Change counter so it's at the right row
            Flag = False 'Reset Start Flag
            TXT = vbNullString 'Reset
            GoTo NextSection
       End If
       TXT = TXT & ActiveSheet.Cells(LngLp, "B") & " " 'Concatenate Text Strings
       Flag = True 'Set Start Flag
       Counter = LngLp 'Set Start Row
    Else
        TXT = TXT & ActiveSheet.Cells(LngLp, "B") & " " 'Concatenate Text Strings
    End If
NextSection:
'Handle Last Merged Cells
If LngLp = Lrow Then
     ActiveSheet.Range(Cells(Counter, "B"), Cells(LngLp, "B")).Merge 'Merge Cells
    ActiveSheet.Range(Cells(Counter, "A"), Cells(LngLp, "A")).Merge 'Merge Cells
    ActiveSheet.Cells(Counter, "B") = Mid(TXT, 1, Len(TXT) - 1) 'Chop of Extra Space
End If

Next LngLp
'Turn Pop Up Alerts Back On
Application.DisplayAlerts = False
End Sub

It should be noted that merged cells are usually frowned upon.  You can use border formatting as well as indentions to accomplish something similar....