Pivoting Columns with a Condition Using VBA

Question

I have a table in excel with more than 100 columns, many of them with the following name structure "INFO_COMPLETE_.....". These columns contain only two possible values ​​which are "TRUE" or "FALSE" (but in spanish).I want to create a new table from pivoting all those columns. The scrutture of the original table is this:

ID_ELEMENT	NAME	DESCRIPTION	INFO_COMPLETE_DATE BEGIN	INFO_COMPLETE_DATE FINISH	INFO_COMPLETE_OTHERS
ID1	NAME1	D1	FALSO	VERDADERO	FALSO
ID2	NAME2	D2	FALSO	FALSO	VERDADERO
ID3	NAME3	D3	VERDADERO	VERDADERO	VERDADERO

The table I want to create would have the following structure

ID_ELEMENT	NAME	FIELD	VALUE
ID1	NAME1	INFO_COMPLETE_DATE BEGIN	FALSO
ID1	NAME1	INFO_COMPLETE_DATE FINISH	VERDADERO
ID1	NAME1	INFO_COMPLETE_OTHERS	FALSO
ID2	NAME2	INFO_COMPLETE_DATE BEGIN	FALSO
ID2	NAME2	INFO_COMPLETE_DATE FINISH	FALSO
ID2	NAME2	INFO_COMPLETE_OTHERS	VERDADERO
ID3	NAME3	INFO_COMPLETE_DATE BEGIN	VERDADERO
ID3	NAME3	INFO_COMPLETE_DATE FINISH	VERDADERO
ID3	NAME3	INFO_COMPLETE_OTHERS	VERDADERO

I just want to keep two columns from the original table which are "ID_ELEMENT" and "NAME" For this I wanted to use the following code that would additionally only keep the "FALSE" values ​​and the "VALUE" column would no longer be necessary. How could I modify the code or is it even possible to simplify it?

Sub PivotColumnsToRows()
    
    ' Variables
    Dim tblDatos As ListObject
    Dim tblNew As ListObject
    Dim newTablename As String
    Dim i As Long, j As Long, k As Long
    Dim ID_ELEMENT As String, nameElement As String, columnElement As String
    Dim bValor As Boolean
    Dim NewSheet As String
    NewSheet = "TABLA_PIVOT" ' Name of the new Sheet
    ThisWorkbook.Worksheets.Add().Name = NewSheet ' Create new Sheet
    
    ' Name of the new table
    newTablename = "DATOS_PIVOT"
    
    ' Reference of the original table (name "Tabla4"), Sheetsname "DATOS"
    Set tblDatos = ThisWorkbook.Worksheets("DATOS").ListObjects("Tabla4")
    
    ' Create new table
    Set tblNew = ThisWorkbook.Worksheets(NewSheet).ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes)
    tblNew.Name = newTablename
    
    ' Add columns to the new table
    With tblNew
        .ListColumns.Add
        .ListColumns.Add
        .ListColumns.Add
    End With
    
    ' Rename columns of the new table
    With tblNew
        .HeaderRowRange(1) = "ID_ELEMENT"
        .HeaderRowRange(2) = "NAME"
        .HeaderRowRange(3) = "FIELD"
    End With
    
    ' Loop for columns of the original table
    For i = 1 To tblDatos.ListColumns.Count
        
        ' "INFO_COMPLETE_"
        If InStr(tblDatos.ListColumns(i).Name, "INFO_COMPLETE_") = 1 Then
            
            ' loop for rows
            For j = 1 To tblDatos.ListRows.Count
                
                ' get ID and name
                ID_ELEMENT = tblDatos.DataBodyRange(j, 1)
                nameElement = tblDatos.DataBodyRange(j, 2)
                
                ' Check the value in the current column
                bValor = tblDatos.DataBodyRange(j, i)
                
                ' If the value is FALSE, add a row to the new table
                If Not bValor Then
                    
                    ' get the name of the actual column
                    columnElement = tblDatos.ListColumns(i).Name
                    
                    ' Add row to the new table
                    tblNew.ListRows.Add
                    k = tblNew.ListRows.Count
                    
                    ' Write values in the new file
                    With tblNew
                        .DataBodyRange(k, 1) = ID_ELEMENT
                        .DataBodyRange(k, 2) = nameElement
                        .DataBodyRange(k, 3) = columnElement
                    End With
                    
                End If
                
            Next j
            
        End If
        
    Next i
    
    ' Style
    tblNew.TableStyle = "TableStyleMedium2"
    
End Sub

Answer 1

Unpivot: Just Check Boolean Values

Sub UnpivotData()

    ' Define constants.
    
    Const SRC_SHEET As String = "DATOS"
    Const SRC_TABLE As String = "Tabla4"
    Const SRC_COLUMNS_LEFT As String = "INFO_COMPLETE_"
    Dim srlColumns(): srlColumns = VBA.Array(1, 2)
    
    Const DST_SHEET As String = "TABLA_PIVOT"
    Const DST_TABLE As String = "DATOS_PIVOT"
    Const DST_TABLE_STYLE As String = "TableStyleMedium2"
    Dim dTitles(): dTitles = VBA.Array("ID_ELEMENT", "NAME", "FIELD")
    
    Const CRITERION As Boolean = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the column indexes of the matching headers to a collection.
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    Dim slo As ListObject: Set slo = sws.ListObjects(SRC_TABLE)
    
    Dim shData(): shData = slo.HeaderRowRange.Value
    Dim scCount As Long: scCount = UBound(shData, 2)
    
    Dim coll As Collection: Set coll = New Collection
    
    Dim c As Long, scHeader As String
    
    For c = 1 To scCount
        scHeader = CStr(shData(1, c))
        If InStr(1, scHeader, SRC_COLUMNS_LEFT, vbTextCompare) = 1 Then ' begins
            coll.Add c
        End If
    Next c
    
    If coll.Count = 0 Then Exit Sub ' no matching columns
    
    Erase shData ' the column indexes are in the collection
    
    ' Combining the source data and the column indexes in the collection,
    ' count and write the column indexes of the matching values
    ' for each row to a collection held in the source columns array.
    
    Dim sData(): sData = slo.DataBodyRange
    Dim srCount As Long: srCount = UBound(sData, 1)
    
    Dim scArr() As Collection: ReDim scArr(1 To srCount)
    Dim drCount As Long: drCount = 1 ' headers
    
    Dim sCol, Item, sr As Long, IsFirstFound As Boolean
    
    For sr = 1 To srCount
        For Each sCol In coll
            Item = sData(sr, sCol)
            If VarType(Item) = vbBoolean Then
                If Item = CRITERION Then
                    If Not IsFirstFound Then
                        Set scArr(sr) = New Collection
                        IsFirstFound = True
                    End If
                    scArr(sr).Add sCol
                    drCount = drCount + 1
                End If
            End If
        Next sCol
        IsFirstFound = False ' reset for the next iteration
    Next sr

    If drCount = 0  Then Exit Sub ' no matching criterion found
        
    Set coll = Nothing ' the columns for each row are in 'scArr'
        
    ' Using the column indexes in the source columns array, write the data
    ' from the source array to the destination array.
        
    Dim dcCount As Long: dcCount = UBound(dTitles) + 1
    Dim dData(): ReDim dData(1 To drCount, 1 To dcCount)
    
    For c = 1 To dcCount
        dData(1, c) = dTitles(c - 1)
    Next c
    
    Dim rcCount As Long: rcCount = dcCount - 1 ' without column label
    Dim dr As Long: dr = 1 ' headers already written
    
    For sr = 1 To srCount
        If Not scArr(sr) Is Nothing Then
            For Each sCol In scArr(sr)
                dr = dr + 1
                For c = 1 To rcCount
                    dData(dr, c) = sData(sr, srlColumns(c - 1)) ' row labels
                Next c
                dData(dr, c) = sData(sr, sCol) ' column label
            Next sCol
        End If
    Next sr
    
    Erase scArr ' relevant data is in 'dData'
    Erase sData ' relevant data is in 'dData'
    
    Application.ScreenUpdating = False
    
    ' Write the values from the destination array to the destination range.
    
    ' Delete the sheet if it exists.
    Dim dsh As Object
    On Error Resume Next
        Set dsh = wb.Sheets(DST_SHEET)
    On Error GoTo 0
    If Not dsh Is Nothing Then
        Application.DisplayAlerts = False ' delete without confirmation
            dsh.Delete
        Application.DisplayAlerts = True
    End If
    
    ' Add a new worksheet...
    Dim dws As Worksheet: Set dws = wb.Sheets.Add(Before:=sws)
    dws.Name = DST_SHEET
    Dim drg As Range: Set drg = dws.Range("A1").Resize(dr, dcCount)
    drg.Value = dData
    
    ' Convert the destination range to a table.
    
    Dim dlo As ListObject:
    Set dlo = dws.ListObjects.Add(xlSrcRange, drg, , xlYes)
    
    With dlo
        .Name = DST_TABLE
        .TableStyle = DST_TABLE_STYLE
        .Range.Columns.AutoFit
    End With
    
    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Unpivot copied to a new table.", vbInformation

End Sub

Answer 2

You are not Pivoting, rather you are UNpivoting.

This is something that can be easily accomplished using Power Query, available in Windows Excel 2010+ and Excel 365 (Windows or Mac)

To use Power Query

• Select some cell in your Data Table
• Data => Get&Transform => from Table/Range or from within sheet
• When the PQ Editor opens: Home => Advanced Editor
• Make note of the Table Name in Line 2
• Paste the M Code below in place of what you see
• Change the Table name in line 2 back to what was generated originally.
• Read the comments and explore the Applied Steps to understand the algorithm

let

//change next line to reflect actual data source
    Source = Excel.CurrentWorkbook(){[Name="Table8"]}[Content],

    #"Changed Type" = Table.TransformColumnTypes(Source,
        List.Transform(Table.ColumnNames(Source), each {_, type text})),

//remove DESCRIPTION column
    #"Removed Columns" = Table.RemoveColumns(#"Changed Type",{"DESCRIPTION"}),

//UNpivot all except the ID ELEMENT and NAME columns
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Removed Columns", {"ID_ELEMENT","NAME"}, "Field", "Value")
in
    #"Unpivoted Other Columns"

Results from your data

So if you want to keep only the False values, and eliminate the Value column, merely add those steps to the above code:

let

//change next line to reflect actual data source
    Source = Excel.CurrentWorkbook(){[Name="Table8"]}[Content],

    #"Changed Type" = Table.TransformColumnTypes(Source,
        List.Transform(Table.ColumnNames(Source), each {_, type text})),

//remove DESCRIPTION column
    #"Removed Columns" = Table.RemoveColumns(#"Changed Type",{"DESCRIPTION"}),

//UNpivot all except the ID ELEMENT and NAME columns
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Removed Columns", {"ID_ELEMENT","NAME"}, "Field", "Value"),

//Filter on FALSO and remove Value column
    #"Filtered Rows" = Table.SelectRows(#"Unpivoted Other Columns", each ([Value] = "FALSO")),
    #"Removed Columns1" = Table.RemoveColumns(#"Filtered Rows",{"Value"})
in
    #"Removed Columns1"

After filter and remove column