Excel VBA转置表

Question

我试图将一张桌子（蓝色）转换成底部的一张桌子。

有人可以帮忙吗？使用Excel VBA方法转置这些数据。

赞赏。谢谢

Answer 1

这样就可以了，它不会传输格式（因为这真的很乏味，我想避免复制单元格）

还可以看看.PasteSpecial Paste:=xlPasteFormats here

复制非常慢并且（软）锁定工作站正在运行 - 在复制时不能使用复制粘贴。

Sub TransposeTable()

' You can also select a sheet like ThisWorkbook.Sheets("MySheet")
Set SourceWorkbook = ThisWorkbook.Sheets(1)
' You can select sheets from other open Workbooks by Application.Workbooks(1) or Application.Workbooks("MyWorkbook.xlsx") instead of ThisWorkbook
Set TargetWorkbook = ThisWorkbook.Sheets(2)

' Check the size of the source table
LastRowSource = SourceWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
LastColumnSource = SourceWorkbook.Cells(1, Columns.Count).End(xlToLeft).Column

' Add more headers below
Headers = Array("Question", "Points", "Some other header", "Yet another header")
HeaderCount = UBound(Headers) + 1 ' Array indices start at 0, Cell columns and rows start at 1

Range(TargetWorkbook.Cells(1, 1), TargetWorkbook.Cells(1, HeaderCount)) = Headers ' Print headers

' Loop all columns in the first row of source table
For Each SourceColumn In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(1, LastColumnSource))
    ' Loop all rows in the first column of the source table
    For Each SourceRow In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(LastRowSource, SourceColumn.Column))
        ' Swap row and column in target and assign value to target
        TargetWorkbook.Cells(SourceColumn.Column + 1, SourceRow.Row).Value = SourceWorkbook.Cells(SourceRow.Row, SourceColumn.Column).Value
    Next SourceRow
Next SourceColumn

End Sub

编辑：根据OP的评论添加更新的解决方案。

' Set this to true if you want to delete TargetWorkbook cells before each run
Const DELETE_TARGET_CELLS = False

Sub TransposeTable()

' You can also select a sheet like ThisWorkbook.Sheets("MySheet")
Set SourceWorkbook = ThisWorkbook.Sheets(1)
' You can select sheets from other open Workbooks by Application.Workbooks(1) or Application.Workbooks("MyWorkbook.xlsx")
Set TargetWorkbook = ThisWorkbook.Sheets(2)

If DELETE_TARGET_CELLS Then TargetWorkbook.Cells.Delete

' Check the size of the source table
LastRowSource = SourceWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
LastColumnSource = SourceWorkbook.Cells(1, Columns.Count).End(xlToLeft).Column

' Add more headers below
Headers = Array("Question", "Points")
HeaderCount = UBound(Headers) + 1 ' Array indices start at 0, Cell columns and rows start at 1
Range(TargetWorkbook.Cells(1, 1), TargetWorkbook.Cells(1, HeaderCount)) = Headers ' Print headers

' We need to also track last row of Target worksheet
LastRowTarget = TargetWorkbook.Cells(Rows.Count, 1).End(xlUp).Row

'Loop first column of all rows of source table, skip first row since we don't want to duplicate headers
For Each SourceRow In Range(SourceWorkbook.Cells(2, 1), SourceWorkbook.Cells(LastRowSource, 1))
    ' Loop all columns of the first row of source table
    For Each SourceColumn In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(2, LastColumnSource))
        ' Copy headers to first column of target table
        TargetWorkbook.Cells(LastRowTarget + 1, 1).Value = SourceWorkbook.Cells(1, SourceColumn.Column).Value
        ' Copy values of the source row to the second column of target table
        TargetWorkbook.Cells(LastRowTarget + 1, 2).Value = SourceWorkbook.Cells(SourceRow.Row, SourceColumn.Column).Value
        ' Update last row number of target table so we don't overwrite finished target rows
        LastRowTarget = TargetWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
    Next SourceColumn
Next SourceRow

End Sub

Answer 2

由于已经提供了程序化的答案，我会给你一些我不会正常给出的虚拟答案，但我认为这对你来说在你遇到类似事情的其他情况下会很有用。

如果您不知道如何在VBA中执行某些操作，请在Excel中记录宏，然后查看其完成方式的代码。转置矩阵是Excel单独可以执行的操作，因此您可以记录Excel执行操作的方式，然后查看代码。

它不会给你最好的代码，但它可以帮助你弄清楚如何做:)