excelvbaexcel-formulalibreoffice-calc

Convert an Excel table from one structure to the other


Original table

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

New table

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

Question

How can I do that in Excel or LibreOffice? My options are:

I'd appreciate any hint or help.

Note

Above, I have shown just the Unit number of 1 as a sample. But unit numbers could continue, like 2, 3, and more.


Solution

  • 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
    

    enter image description here