I have this table in Excel or LibreOffice.
Unit number | Type | Name |
---|---|---|
1 | Object | Top |
1 | Object | Bottom |
1 | Object | Left |
1 | Object | Right |
1 | Object | Back |
1 | Object | Front |
1 | Property | Right-Fixed |
1 | Property | Left-Fixed |
1 | Property | 4-legs |
I want to convert this table to a new one. I want to keep only the rows with the Type equal to Object and apply the Properties as new columns. Like below.
Unit number | Type | Name | Right-fixed | Left-fixed | 4-legs |
---|---|---|---|---|---|
1 | Object | Top | |||
1 | Object | Bottom | True | ||
1 | Object | Left | True | ||
1 | Object | Right | True | ||
1 | Object | Back | |||
1 | Object | Front |
How can I do that in Excel or LibreOffice? My options are:
I'd appreciate any hint or help.
Above, I have shown just the Unit number of 1
as a sample. But unit numbers could continue, like 2
, 3
, and more.
Option Explicit
Sub Demo()
Dim arrData, rngData As Range
Dim arrRes, iR As Long, i As Long
Dim LastRow As Long, sHeader As String
Dim dataSht As Worksheet, mapSht As Worksheet
Dim oDicMap As Object, oDicCol As Object
Dim oDicRow As Object, oDic As Object, sKey
Const BASE_COLS = 3 ' The first 3 cols on output table are fixed
Set dataSht = Sheets("Sheet1") ' modify as needed
Set mapSht = Sheets("Sheet2")
' Load mapping table
Set oDicMap = CreateObject("scripting.dictionary")
arrData = mapSht.Range("A1").CurrentRegion.Value
For i = LBound(arrData) + 1 To UBound(arrData)
oDicMap(arrData(i, 1)) = arrData(i, 2)
Next i
' Load source data
Set oDicCol = CreateObject("scripting.dictionary")
arrData = dataSht.Range("A1").CurrentRegion.Value
iR = BASE_COLS
' Get header names of output
For i = LBound(arrData) + 1 To UBound(arrData)
If arrData(i, 2) = "Property" Then
iR = iR + 1
oDicCol(arrData(i, 3)) = iR
End If
Next i
Set oDic = CreateObject("scripting.dictionary")
Set oDicRow = CreateObject("scripting.dictionary")
' Output table header
ReDim arrRes(1 To UBound(arrData), 1 To iR)
arrRes(1, 1) = "Unit"
arrRes(1, 2) = "Type"
arrRes(1, 3) = "Name"
For Each sKey In oDicCol.Keys
arrRes(1, oDicCol(sKey)) = sKey
Next
iR = 1
' Loop through data
For i = LBound(arrData) + 1 To UBound(arrData)
' Add a new row for Object
If arrData(i, 2) = "Object" Then
iR = iR + 1
arrRes(iR, 1) = arrData(i, 1)
arrRes(iR, 2) = arrData(i, 2)
arrRes(iR, 3) = arrData(i, 3)
sKey = arrData(i, 1) & arrData(i, 3)
oDicRow(sKey) = iR
ElseIf arrData(i, 2) = "Property" Then
' Insert True
If oDicMap.exists(arrData(i, 3)) And oDicCol.exists(arrData(i, 3)) Then
sKey = arrData(i, 1) & oDicMap(arrData(i, 3))
If oDicRow.exists(sKey) Then
arrRes(oDicRow(sKey), oDicCol(arrData(i, 3))) = True
End If
End If
End If
Next i
' Write ouput to sheet
Sheets.Add
Range("A1").Resize(iR, UBound(arrRes, 2)).Value = arrRes
ActiveSheet.UsedRange.EntireColumn.AutoFit
End Sub