excel 使用VBA旋转具有条件的柱

bkhjykvo  于 2023-04-07  发布在  其他
关注(0)|答案(2)|浏览(95)

我在excel中有一个表,其中有100多列,其中许多列的名称结构为“INFO_COMPLETE_.....”。 这是“TRUE”或“FALSE”(但在西班牙语).我想创建一个新的表从所有这些列透视.原表的结构是这样的:
| ID_元素|名称|描述|INFO_COMPLETE_DATE开始|信息_完成_完成日期|信息_完成_其他|
| --------------|--------------|--------------|--------------|--------------|--------------|
| ID1|名称1|D1|FALSO|贝达德罗|FALSO|
| ID2|名称2|D2|FALSO|FALSO|贝达德罗|
| ID3|名称3|D3|贝达德罗|贝达德罗|贝达德罗|
我要创建的表将具有以下结构
| ID_元素|名称|FIELD|价值|
| --------------|--------------|--------------|--------------|
| ID1|名称1|INFO_COMPLETE_DATE开始|FALSO|
| ID1|名称1|信息_完成_完成日期|贝达德罗|
| ID1|名称1|信息_完成_其他|FALSO|
| ID2|名称2|INFO_COMPLETE_DATE开始|FALSO|
| ID2|名称2|信息_完成_完成日期|FALSO|
| ID2|名称2|信息_完成_其他|贝达德罗|
| ID3|名称3|INFO_COMPLETE_DATE开始|贝达德罗|
| ID3|名称3|信息_完成_完成日期|贝达德罗|
| ID3|名称3|信息_完成_其他|贝达德罗|
我只想保留原始表中的两列,分别是“ID_ELEMENT”和“NAME”。为此,我想使用以下代码,另外只保留“FALSE”值 而且“值”列将不再是必要的。我该如何修改代码,甚至有可能简化它?

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
6pp0gazn

6pp0gazn1#

你不是在旋转,而是在不旋转。
这是可以使用Power Query轻松完成的事情,在Windows Excel 2010+和Excel 365(Windows或Mac)中提供
使用Power Query

  • 选择数据表中的某个单元格
  • Data => Get&Transform => from Table/Rangefrom within sheet
  • PQ编辑器打开时:Home => Advanced Editor
  • 记下第2行中的表名称
  • 将下面的M代码粘贴到您所看到的位置
  • 将第2行中的Table名称更改回最初生成的名称。
  • 阅读评论并浏览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"

过滤并删除列后

idv4meu8

idv4meu82#

反透视:只检查布尔值

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

相关问题