Transpose Data Set Macro / VBA help!

This is a bit clumsy but seems to work - Put this event in the sheet module:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Value <> "" Then
Application.EnableEvents = False
Dim r As Long, c As Long, i As Long, n As Long: n = 2
Dim Index As String, Item As String, S As String
Index = Left(Cells(2, 1), InStr(1, Cells(2, 1), " ") - 1)
i = InStr(1, Cells(2, 1), " ")
Item = Right(Cells(2, 1), Len(Cells(2, 1)) - i)
S = Index
For r = 2 To Range("A" & Rows.Count).End(xlUp).Row
i = InStr(1, Cells(r, 1), " ")
Item = Right(Cells(r, 1), Len(Cells(r, 1)) - i)

If Left(Cells(r, 1), i - 1) = Index Then
S = S & "," & Item: c = c + 1: GoTo GetNext
End If

c = c + 1: Cells(n, 2).Resize(1, c) = Split(S, ","): n = n + 1
Index = Left(Cells(r, 1), InStr(1, Cells(r, 1), " ") - 1)
c = 0: r = r - 1: S = Index
GetNext: Next r
c = c + 1: Cells(n, 2).Resize(1, c) = Split(S, ",")
End If
Application.EnableEvents = True
End Sub

Try this code (originally written by Mr. Karedog .. Credits go to him)

Sub Test()
    Dim coll        As New Collection
    Dim arr         As Variant
    Dim v1          As Variant
    Dim v2          As Variant
    Dim str1        As String
    Dim maxItem     As Long
    Dim i           As Long
    Dim j           As Long

    arr = Sheets("Sheet1").Range("A1").CurrentRegion.Value

    For i = 1 To UBound(arr, 1)
        str1 = CStr(arr(i, 1))

        On Error Resume Next
            coll.Add Key:=str1, Item:=New Collection
        On Error GoTo 0

        If coll(str1).Count = 0 Then coll(str1).Add str1
        For j = 2 To UBound(arr, 2)
            If Len(arr(i, j)) Then coll(str1).Add CStr(arr(i, j))
        Next j
    Next i

    For Each v1 In coll
        If v1.Count > maxItem Then maxItem = v1.Count
    Next v1

    ReDim arr(1 To coll.Count, 1 To maxItem)
    i = 0
    For Each v1 In coll
        i = i + 1
        j = 0
        For Each v2 In v1
            j = j + 1
            arr(i, j) = v2
        Next v2
    Next v1

    Sheets("Sheet1").Range("D1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

see if this works for you. paste it into the code module of the required sheet.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim DataRng As Range
    Dim DataArr() As Variant, i As Long
    Dim Key As String, DataValue As String
    Dim KeyStore As String, DataCol As New Collection
    Dim KeyPosition As Long, TempDataValue As String
    
    'define DataRng, Col A (+1 to account for deletion of data in last row)
    Set DataRng = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row + 1)
    
    'only process if change in DataRng
    If Intersect(Target, DataRng) Is Nothing Then Exit Sub
    
    'store data in 1D array
    DataArr = Application.Transpose(DataRng)
    
    'process data
    For i = LBound(DataArr) To UBound(DataArr)
    
        'only process if data present & has space delimiter
        If Not IsEmpty(DataArr(i)) And InStr(DataArr(i), " ") > 0 Then
    
            'assign current Key & DataValue pair to temp variables
            Key = Split(DataArr(i), " ")(0)
            DataValue = Split(DataArr(i), " ")(1)
        
            'test if Key already stored
            If InStr(KeyStore, Key) = 0 Then 'not stored
            
                'add Key to KeyStore
                KeyStore = KeyStore & "_" & Key
            
                'add DataValue to collection incl. Key before as first entry
                Call DataCol.Add(Key & " " & DataValue, Key)
            
            Else 'already stored
            
                'determine postion of key in collection
                KeyPosition = InStr(KeyStore, Key) / 2
            
                'store matching collection item to TempDataValue
                TempDataValue = DataCol.Item(Key)
                
                'delete matching collection item
                Call DataCol.Remove(Key)
                
                're-create collection item with new data appended
                If KeyPosition > DataCol.Count Then
                    Call DataCol.Add(TempDataValue & " " & DataValue, Key) 'last position
                Else
                    Call DataCol.Add(TempDataValue & " " & DataValue, Key, KeyPosition)
                End If
            
            End If
            
        End If

    Next i
    
    'redim array for output
    ReDim DataArr(1 To DataCol.Count)
    
    'copy collection to array
    For i = LBound(DataArr) To UBound(DataArr)

        DataArr(i) = DataCol.Item(i)

    Next i
    
    'clear col B
    Cells(1, 2).Resize(Cells(Rows.Count, 2).End(xlUp).Row).ClearContents
    
    'output array to col B
    Cells(1, 2).Resize(UBound(DataArr)) = Application.Transpose(DataArr)

End Sub

this splits each key/data pair on the " " delimiter, it will bypass any data which doesn't contain the " " delimiter or if the cell is empty.

I'm using a Collection and String as a make shift Dictionary for the key/data pair of each row. it's a little clunky but as Scripting Dictionary is only available on windows machines I prefer to avoid them unless I'm sure the code will only ever be run on windows machines.

You're welcome