使用 VBA 将 Excel 表从宽转换为长

Question

我想通过使用循环的 VBA 代码将表格从宽格式重塑为长格式。

出于自动化目的，我更喜欢 VBA，尤其是我每次都需要将所有表格合并到一张表中。

简单样本表：

代码	高度	重量	颜色
z123	131	40	0
z876	231	50	1

决赛桌应如下所示。 这些代码需要在 A 列中重复，以对应于 B 列中指定的身高、体重和颜色参考。

代码	参考	价值观
z123	高度	131
z876	高度	231
z123	重量	40
z876	重量	50
z123	颜色	0
z876	颜色	1

代码在A列，身高、体重、颜色等属性在B列，数值在C列。

Answer 1

如果您在 MS Access 数据库中有宽表，请将以下 VBA 代码放在模块中并运行 RotateTable() function 将从原始宽表中读取每一列并将其转换为三列的垂直查询，代码，参考和 ref_value。 您需要做的就是更改代码中的宽表名称。 结果查询匹配您想要的 output

Public Function PickValues(col_name, table_name)
    Dim union_str As String
    union_str = "SELECT code, '" & col_name & "' as Ref,  [" & col_name & "] as ref_value FROM " & table_name & " UNION ALL "
    PickValues = union_str
End Function

Public Sub RotateTable()
    Dim db As DAO.Database
    Dim tdfld As DAO.TableDef
    Dim fld As Field
    Dim table_name As String
    Dim full_union_str As String
     
    table_name = "wide_table" 'change this
    full_union_str = ""
    Set db = CurrentDb()
    Set tdfld = db.TableDefs(table_name)
    For Each fld In tdfld.Fields    'loop through all the fields of the tables
        If Not fld.Name = "code" Then 'Ignore for code column
            col_name = fld.Name
            sub_union_str = PickValues(col_name, table_name)
            full_union_str = full_union_str & sub_union_str
        End If
    Next
    trimmed_select_str = Left(full_union_str, Len(full_union_str) - (Len(" UNION ALL "))) 'this removes the last union string
    Set tdfld = Nothing
    Set db = Nothing
    
    On Error Resume Next
    Set qdf = CurrentDb.CreateQueryDef("qry_rotated", trimmed_select_str)
    DoCmd.OpenQuery qdf.Name
    On Error GoTo 0

结束子

Answer 2

重新排列行切片中的数据并写入 ListObject

显然，OP 不仅想要一个简单的反透视操作，还想要重新排列行值并（覆盖）写入给定的ListObject 。 以下代码演示了这种好处

• 从Application.Index() function和
• 从调整 ListObject 的大小。

Sub Rearrange(rng As Range)
    '[0] get data
    Dim data:        data = rng
    Dim categories:  categories = Application.Index(data, 1, 0)
    '[1] provide for sufficient array rows
    Dim cnt As Long: cnt = UBound(data)
    Dim results: ReDim results(1 To (UBound(categories) - 1) * (cnt - 1))
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '[2] arrange data in wanted order
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim cat As Long
    For cat = 2 To UBound(categories)                ' Height, Weight, Color
        Dim i As Long, ii As Long
        For i = 2 To cnt                             ' e.g. data rows 2:4
            ' collect all relevant data in row columns and
            ' overwrite inserted 2nd col with category
            Dim currData
            currData = Application.Index(data, Evaluate("row(" & i & ":" & i & ")"), Array(1, 0, cat))
            currData(2) = categories(cat)            ' replace 2nd column w/ category
            '
            ii = ii + 1: results(ii) = currData      ' increment row counter
        Next i
    Next cat
    'put array rows together
    results = Application.Index(results, 0, 0)

    '[3] write results to target
    ' a) define captions
    Dim captions: captions = Split("Code,Ref,Value", ",")
    
    ' b) write to another listobject or overwrite given listobject
    '    (~~> change target to your needs)
    With Tabelle1.ListObjects("MyTable2")
        ' Get number of rows to adjust
        Dim rowCorr As Long, colCorr As Long
        rowCorr = UBound(results) - LBound(results) + 1 - .DataBodyRange.Rows.Count
        colCorr = UBound(results, 2) - LBound(results, 2) + 1 - .DataBodyRange.Columns.Count
        Debug.Print "Rows/Cols to adjust = " & rowCorr & "/" & colCorr
        
        'Adjust list object
        If rowCorr < 0 Then            ' Delete Rows
            .DataBodyRange.Rows(1).Resize(Abs(rowCorr)).Delete xlShiftUp
        ElseIf rowCorr > 0 Then        ' Insert rows
            .DataBodyRange.Rows(1).Resize(rowCorr).Insert Shift:=xlDown
        End If
        If colCorr < 0 Then            ' Delete Cols
            .Range.Resize(, Abs(colCorr)).Columns.Delete
        ElseIf colCorr > 0 Then        ' Insert cols
            .Range.Resize(, colCorr).Columns.Insert
        End If
                
        'overwrite data
        .HeaderRowRange = captions
        .DataBodyRange = results
    End With
    
End Sub

调用代码示例

你可以开始想要的重新排列，例如

    Rearrange Sheet1.ListObjects("MyTable").Range

甚至与

    Rearrange Sheet1.Range("A1:D3")

如果您可能想要写入范围目标（例如另一张纸）而不是ListObject ，您可以替换部分[3]b)例如

    With Sheet2.Range("A1")
        .Resize(1, UBound(captions) + 1) = captions
        .Offset(1).Resize(UBound(results), UBound(results, 2)) = results
    End With

和/或将代码拆分为几个子过程。