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

我想用一个循环的VBA代码将表格从宽格式改为长格式

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

简单示例表：

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

---

如果您的宽表位于MS Access数据库中，将下面的VBA代码放在模块中并运行RotateTable（）函数将从原始宽表中读取每一列，并将其转换为三列的垂直查询：code、ref和ref_value。 您需要做的就是更改代码中的宽表名。 结果查询与所需的输出匹配

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

---

结束子对象

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

显然，OP不希望只执行一个简单的unpivot操作，而是要重新排列行值并（覆盖）写入给定的ListObject。下面的代码演示了这一好处

• 从和
• 从调整ListObject的大小

甚至

    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

---

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

基本上，要求是a列中的代码，b列中的其他属性（高度、重量、颜色等）和C列中的值。然而，代码产生了这种结果……a列中的代码z123正确，然后b列中的高度、重量和颜色，C和D（不正确）那么相应的值在B列、C列和D列（不正确）下面，这是否回答了您的问题？我发布的链接中的代码应该可以正常工作。它也会给你值，但你可以随时删除。谢谢。我的表格是Excel格式的，不使用MS Access数据库。以前，我可以通过stata轻松更改格式。但是，我们不再使用Stata，我的老板希望它在Excel上具有必要的自动化。@XtinzTV请允许我说一句：您的问题有两种解决方案-如果有帮助，请在相关答案附近勾选绿色复选标记，随意接受您喜欢的解决方案。到岸价。

    Rearrange Sheet1.Range("A1:D3")

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