I think you need to move down the column  concatonating the cell contents.
There are a number of ways of doing this.

For example... Assuming the data starts in A1 and there are no empty cells
till the end....

Sub subCollateData()

Dim slSummary() As String
Dim slSplit() As String
Dim slName As String
Dim ilUBound As Integer
Dim slValue As String

' Go to the sheet and select top cell.
Sheets("sheet1").Activate
Range("a1").Select

' Set up variables.
slName = ""
slValue = ""
ReDim slSummary(0)
slSummary(0) = "Region Summary"

' Loop till first empty cell.
Do

' Split up data into an array.
slSplit = Split(ActiveCell.Value)

' Are we at the end?
If Len(ActiveCell.Value) = 0 Then

' Get last data item.
slValue = Mid(slValue, 1, Len(slValue) - 1)
ilUBound = UBound(slSummary) + 1
ReDim Preserve slSummary(ilUBound)
slSummary(ilUBound) = slName & " " & slValue
slValue = ""
Exit Do
End If
If slSplit(0) <> slName Then
If ActiveCell.Row > 1 Then
slValue = Mid(slValue, 1, Len(slValue) - 1)
ilUBound = UBound(slSummary) + 1
ReDim Preserve slSummary(ilUBound)
slSummary(ilUBound) = slName & " " & slValue
slValue = ""
End If
slName = slSplit(0)
End If
slValue = slValue & slSplit(1) & ","
ActiveCell.Offset(1, 0).Select
Loop

Sheets("sheet2").Activate
Range("a1").Select
For ilUBound = 0 To UBound(slSummary)
ActiveCell.Value = slSummary(ilUBound)
ActiveCell.Offset(1, 0).Select
Next ilUBound
Range("a1").Select

End Sub

The above ... though Q&D .... should do what you want.