使用 VBA 根据条件透视列

Question

我在Excel中有一个包含100多个列的表，其中许多列的名称结构如下“INFO_COMPLETE_.....”。这些列仅包含两个可能的值，即“TRUE”或“FALSE”（但为西班牙语）。我想通过旋转所有这些列来创建一个新表。 原表的结构是这样的：

ID_元素	姓名	描述	INFO_COMPLETE_DATE BEGIN	INFO_COMPLETE_DATE 完成	INFO_COMPLETE_OTHERS
ID1	姓名1	D1	假话	韦尔达德罗	假话
ID2	姓名2	D2	假话	假话	韦尔达德罗
ID3	名字3	D3	韦尔达德罗	韦尔达德罗	韦尔达德罗

我想要创建的表将具有以下结构

ID_元素	姓名	场	价值
ID1	姓名1	INFO_COMPLETE_DATE BEGIN	假话
ID1	姓名1	INFO_COMPLETE_DATE 完成	韦尔达德罗
ID1	姓名1	INFO_COMPLETE_OTHERS	假话
ID2	姓名2	INFO_COMPLETE_DATE BEGIN	假话
ID2	姓名2	INFO_COMPLETE_DATE 完成	假话
ID2	姓名2	INFO_COMPLETE_OTHERS	韦尔达德罗
ID3	名字3	INFO_COMPLETE_DATE BEGIN	韦尔达德罗
ID3	名字3	INFO_COMPLETE_DATE 完成	韦尔达德罗
ID3	名字3	INFO_COMPLETE_OTHERS	韦尔达德罗

我只想保留原始表中的两列，即“ID_ELEMENT”和“NAME” 为此，我想使用以下代码，该代码仅保留“FALSE”值，并且不再需要“VALUE”列。我该如何修改代码或者是否可以简化它？

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

你不是在旋转，而是在取消旋转。

使用 Windows Excel 2010+ 和 Excel 365（Windows 或 Mac）中提供的 Power Query 可以轻松完成此任务

使用 Power Query

• 选择数据表中的某个单元格

• Data => Get&Transform => from Table/Range

  或

  from within sheet

• PQ 编辑器打开时：

  Home => Advanced Editor

• 记下第 2 行中的表名称
• 将下面的 M 代码粘贴到您所看到的位置
• 将第 2 行中的表名称更改回最初生成的名称。
• 阅读评论并探索

  Applied Steps

  以了解算法

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"

您的数据结果

因此，如果您只想保留 False 值，并消除 Value 列，只需将这些步骤添加到上面的代码中即可：

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"

过滤并移除柱后

Answer 2

Unpivot：只需检查布尔值

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