假设您的示例（在您的帖子中）位于名为 "Sheet2" 的工作表上，代码将尝试将转置后的数组输出到 E 列（因此您可能希望在运行之前保存/制作副本）。
Option Explicit
Private Sub TransposeWithRepeatingHeaders()
With ThisWorkbook.Worksheets("Sheet2")
Dim inputArray() As Variant
inputArray = .Range("A1:C4").Value2
Dim rowCountInOutput As Long
' Multiplied by two because each item will be preceded by a "header"
rowCountInOutput = (UBound(inputArray, 1) - 1) * UBound(inputArray, 2) * 2
Dim outputArray() As Variant
ReDim outputArray(1 To rowCountInOutput, 1 To 1)
Dim readRowIndex As Long
Dim readColumnIndex As Long
Dim writeIndex As Long
For readRowIndex = (LBound(inputArray, 1) + 1) To UBound(inputArray, 1) ' Skip header on first row
For readColumnIndex = LBound(inputArray, 2) To UBound(inputArray, 2)
writeIndex = writeIndex + 1
outputArray(writeIndex, 1) = inputArray(1, readColumnIndex) ' Assumes headers are on first row of inputArray
writeIndex = writeIndex + 1
outputArray(writeIndex, 1) = inputArray(readRowIndex, readColumnIndex)
Next readColumnIndex
Next readRowIndex
.Range("E1").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray
End With
End Sub
编辑：如果您需要处理更大的数组/范围，下面的代码可能是更好的方法。目前，堆叠数组将写入源数据右侧的两列（如果需要，请更改此设置）。
您可以调整常量MAXIMUM_CHUNK_SIZE（在任何给定时间要处理的最大行数）来查看您的机器可以处理什么。我想如果它太小，代码将需要更长的时间才能完成，如果它太大，您可能会遇到内存问题。 10000 可能是一个不错的起点，我不知道。
Option Explicit
Private Sub StackWithRepeatingHeaders()
Const MAXIMUM_CHUNK_SIZE As Long = 10000 ' More specifically, the maximum number of rows to consume per iteration
With ThisWorkbook.Worksheets("Sheet2")
Dim inputRange As Range
Set inputRange = .Range("A1:Z20000") ' Include headers please
Dim columnHeaders As Variant
columnHeaders = Application.Index(inputRange, 1, 0)
Dim inputColumnCount As Long
inputColumnCount = inputRange.Columns.Count
' Store only the "body", as "headers" are being stored in their own array
Set inputRange = inputRange.Offset(1, 0).Resize(inputRange.Rows.Count - 1, inputColumnCount)
Dim inputRowCount As Long
inputRowCount = inputRange.Rows.Count
Dim totalOutputRowCount As Long ' Multiplied by two because each item will be preceded by a "header"
totalOutputRowCount = inputRowCount * inputColumnCount * 2
If totalOutputRowCount > .Rows.Count Then
MsgBox ("There are not enough rows in this sheet to stack this range (" & Format$(totalOutputRowCount, "#,###") & " rows required). Code will stop running now.")
Exit Sub
End If
Dim firstOutputCell As Range ' Stack from this cell downward
Set firstOutputCell = .Cells(1, inputRange.Columns(inputRange.Columns.Count).Column + 2) ' +2 could error if inputrange ends near last column of sheet
End With
Dim outputArray() As Variant
ReDim outputArray(1 To (MAXIMUM_CHUNK_SIZE * inputColumnCount * 2), 1 To 1)
Dim chunkStartIndex As Long
For chunkStartIndex = 1 To inputRowCount
Dim currentChunkSize As Long
currentChunkSize = Application.Min(MAXIMUM_CHUNK_SIZE, inputRowCount - chunkStartIndex + 1)
Dim inputArray() As Variant
inputArray = inputRange.Offset(chunkStartIndex - 1, 0).Resize(currentChunkSize, inputColumnCount).Value2 ' -1 as 0-based
If currentChunkSize <> MAXIMUM_CHUNK_SIZE Then
' Think this line will only run on the last iteration (when "remaining rows" might be < MAXIMUM_CHUNK_SIZE)
' Avoids needless Redims
ReDim outputArray(1 To (currentChunkSize * inputColumnCount * 2), 1 To 1)
End If
Dim readRowIndex As Long
Dim readColumnIndex As Long
Dim arrayWriteIndex As Long
arrayWriteIndex = 0
For readRowIndex = 1 To currentChunkSize
For readColumnIndex = 1 To inputColumnCount
arrayWriteIndex = arrayWriteIndex + 1
outputArray(arrayWriteIndex, 1) = columnHeaders(1, readColumnIndex)
arrayWriteIndex = arrayWriteIndex + 1
outputArray(arrayWriteIndex, 1) = inputArray(readRowIndex, readColumnIndex)
Next readColumnIndex
Next readRowIndex
Dim sheetWriteIndex As Long
firstOutputCell.Offset(sheetWriteIndex, 0).Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray
sheetWriteIndex = sheetWriteIndex + (currentChunkSize * inputColumnCount * 2)
chunkStartIndex = chunkStartIndex + currentChunkSize - 1
Next chunkStartIndex
End Sub