Aug 22 2019 02:03 AM
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!
Aug 22 2019 01:54 PM
Solution
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
Aug 28 2019 04:39 AM
It works like a charm!
Thanks a bunch, Subodh
Aug 28 2019 06:34 AM
You're welcome! Glad it worked as desired.
Aug 22 2019 01:54 PM
Solution
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