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如何执行操作，然后查看代码。

它不会为您提供最佳的代码，但可以帮助您弄清楚如何做：）