Excel formula to transfer values into new table with their types as column headers

[SourcePilot]

Hello,

I have a specific problem and am wondering if there is a formula or something to that effect that I can use.

The question in the title may be a little confusing, so here is an example.

Let's say I have a sheet containing variables and their type in the cell just left of it, respectively:

Car:	Honda	Motorbike:	BMW
Car:	BMW
Motorbike:	Suzuki
Motorbike:	Yamaha	Plane:	Concorde

And I want it to look like this instead:

Car	Motorbike	Plane
Honda	BMW
BMW
	Suzuki
	Yamaha	Concorde

Is there a convenient way to transform the data like this?

Any help is appreciated!

[#2 · Accepted solution]

@SourcePilot 

You may try the following macro to transform the data into the desired format.

In the attached, click the button called "Transform Data" on Sheet1 to run the code.

Sub TransformData()
Dim wsData As Worksheet, wsOutupt As Worksheet
Dim x, y(), dict, it
Dim i As Long, j As Long
Dim c

Application.ScreenUpdating = False

Set wsData = Worksheets("Sheet1")       'Data Sheet

On Error Resume Next
Set wsOutupt = Worksheets("Output")     'Transformed data will be placed on this sheet
wsOutupt.Cells.Clear
On Error GoTo 0

If wsOutupt Is Nothing Then
    Set wsOutupt = Worksheets.Add(after:=wsData)
    wsOutupt.Name = "Output"            'Transformed data will be placed on this sheet
End If

x = wsData.Range("A1").CurrentRegion.value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    For j = 1 To UBound(x, 2)
        If InStr(x(i, j), ":") > 0 Then
            dict.Item(x(i, j)) = ""
        End If
    Next j
Next i

If dict.Count = 0 Then
    MsgBox "Data not in desired format!", vbExclamation
    Exit Sub
End If

ReDim y(1 To UBound(x, 1) + 1, 1 To dict.Count)

j = 0

For Each it In dict.keys
    j = j + 1
    y(1, j) = it
Next it

For i = 1 To UBound(x, 1)
    For j = 1 To UBound(x, 2)
        If InStr(x(i, j), ":") > 0 Then
            c = Application.Match(x(i, j), Application.Index(y, 1, 0), 0)
            If Not IsError(c) Then
                y(i + 1, c) = x(i, j + 1)
            End If
        End If
    Next j
Next i

wsOutupt.Range("A1").Resize(UBound(y, 1), UBound(y, 2)).value = y

With wsOutupt.Rows(1)
    .Replace ":", ""
    .Font.Bold = True
    .Font.Size = 12
End With

With wsOutupt.Range("A1").CurrentRegion
    .Columns.AutoFit
    .Borders.Color = vbBlack
End With

wsOutupt.Select

Application.ScreenUpdating = True
End Sub

[#3]

@Subodh_Tiwari_sktneer 

It works like a charm!

Thanks a bunch, Subodh

[#4]

@SourcePilot 

You're welcome! Glad it worked as desired.