我有一个如下所示的excel表
A B C
1 name company address
2 john apple london
3 jack microsoft kent
4 ahmed spacex ca
但是我需要将其转换为以下
A
1 name
2 john
3 company
4 apple
5 address
6 london
7 name
8 jack
9 company
10 microsoft
11 address
12 kent
13 name
14 ahmed
15 company
16 spacex
17 address
18 ca
如何使用VBA实现？主要问题似乎是在复制标题之类的标题，因为每个名称都需要在同一列中的每个标题上方都包含一个标题，因此将不胜感激。
答案 0 :(得分：3)
尝试使其适应您的工作表名称：
Sub ReConfigure()
Dim s1 As Worksheet, s2 As Worksheet, h1 As String, h2 As String, h3 As String
Dim i As Long, j As Long, N As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
j = 1
With s1
h1 = .Range("A1")
h2 = .Range("B1")
h3 = .Range("C1")
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To N
s2.Cells(j, 1) = h1
j = j + 1
s2.Cells(j, 1).Value = .Cells(i, 1).Value
j = j + 1
s2.Cells(j, 1) = h2
j = j + 1
s2.Cells(j, 1).Value = .Cells(i, 2).Value
j = j + 1
s2.Cells(j, 1).Value = h3
j = j + 1
s2.Cells(j, 1).Value = .Cells(i, 3).Value
j = j + 1
Next i
End With
End Sub
我将Sheet1用于输入，将Sheet2用于输出。
答案 1 :(得分：3)
假设您的示例（在您的帖子中）在名为"Sheet2"的工作表上，代码将尝试将转置后的数组输出到E列（因此您可能希望在运行之前保存/创建副本）。 / p>
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
答案 2 :(得分：3)
您可以尝试这样做（将“ mySheetName”更改为您的实际工作表名称）：
Sub TransposeAndDuplicateHeaders()
Dim arr As Variant
With Worksheets("mySheetName")
arr = .UsedRange.Value
.UsedRange.ClearContents
Dim i As Long, j As Long
For i = 2 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
.Cells((i - 1) * UBound(arr, 2) + (j - 1) * 2 + 1, 1).Value = arr(1, j)
.Cells((i - 1) * UBound(arr, 2) + (j - 1) * 2 + 2, 1).Value = arr(i, j)
Next
Next
End With
End Sub
警告：这将清除“ mySheetName”工作表的原始内容，因此请制作备份副本