Excelmacros（VBA）将多列转置为多行

这种转变正是我想要实现的。 只是为了说明，我已经把它作为表。所以基本上，前3列应该重复有多less颜色可用。

我search了其他类似的，但是当我想要重复多列的时候找不到。 我发现这个代码在线，但它是名称感谢位置感谢位置感谢位置感谢位置，并使其如下名称谢谢位置

Sub createData() Dim dSht As Worksheet Dim sSht As Worksheet Dim colCount As Long Dim endRow As Long Dim endRow2 As Long Set dSht = Sheets("Sheet1") 'Where the data sits Set sSht = Sheets("Sheet2") 'Where the transposed data goes sSht.Range("A2:C60000").ClearContents colCount = dSht.Range("A1").End(xlToRight).Column '// loops through all the columns extracting data where "Thank" isn't blank For i = 2 To colCount Step 2 endRow = dSht.Cells(1, i).End(xlDown).Row For j = 2 To endRow If dSht.Cells(j, i) <> "" Then endRow2 = sSht.Range("A50000").End(xlUp).Row + 1 sSht.Range("A" & endRow2) = dSht.Range("A" & j) sSht.Range("B" & endRow2) = dSht.Cells(j, i) sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1) End If Next j Next i End Sub 

有人可以帮助改变我想要的格式，我试着改变步骤2到1，j从4开始，但是没有帮助另一个例如有2​​个不同的集合：

Answer 1

这是一个通用的“不透明”方法（所有“固定”列必须出现在input数据的左侧）

testing子：

 Sub Tester() Dim p 'get the unpivoted data as a 2-D array p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _ 3, False, False) With Sheets("Sheet1").Range("H1") .CurrentRegion.ClearContents .Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet End With 'EDIT: alternative (slower) method to populate the sheet ' from the pivoted dataset. Might need to use this ' if you have a large amount of data Dim r As Long, c As Long For r = 1 To Ubound(p, 1) For c = 1 To Ubound(p, 2) Sheets("Sheet2").Cells(r, c).Value = p(r, c) Next c Next r End Sub 

UnPivotfunction：

 Function UnPivotData(rngSrc As Range, fixedCols As Long, _ Optional AddCategoryColumn As Boolean = True, _ Optional IncludeBlanks As Boolean = True) Dim nR As Long, nC As Long, data, dOut() Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long Dim outRows As Long, outCols As Long data = rngSrc.Value 'get the whole table as a 2-D array nR = UBound(data, 1) 'how many rows nC = UBound(data, 2) 'how many cols 'calculate the size of the final unpivoted table outRows = nR * (nC - fixedCols) outCols = fixedCols + IIf(AddCategoryColumn, 2, 1) 'resize the output array ReDim dOut(1 To outRows, 1 To outCols) 'populate the header row For c = 1 To fixedCols dOut(1, c) = data(1, c) Next c If AddCategoryColumn Then dOut(1, fixedCols + 1) = "Category" dOut(1, fixedCols + 2) = "Value" Else dOut(1, fixedCols + 1) = "Value" End If 'populate the data rOut = 1 For r = 2 To nR For cat = fixedCols + 1 To nC If IncludeBlanks Or Len(data(r, cat)) > 0 Then rOut = rOut + 1 'Fixed columns... For c = 1 To fixedCols dOut(rOut, c) = data(r, c) Next c 'populate unpivoted values If AddCategoryColumn Then dOut(rOut, fixedCols + 1) = data(1, cat) dOut(rOut, fixedCols + 2) = data(r, cat) Else dOut(rOut, fixedCols + 1) = data(r, cat) End If End If Next cat Next r UnPivotData = dOut End Function 

Answer 2

这是使用数组的一种方法（ 最快？ ）。 这种方法更好的是链接的问题，因为它不会读写循环中的范围对象。 我已经评论了代码，所以你不应该有理解它的问题。

 Option Explicit Sub Sample() Dim wsThis As Worksheet, wsThat As Worksheet Dim ThisAr As Variant, ThatAr As Variant Dim Lrow As Long, Col As Long Dim i As Long, k As Long Set wsThis = Sheet1: Set wsThat = Sheet2 With wsThis '~~> Find Last Row in Col A Lrow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Find total value in D,E,F so that we can define output array Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow)) '~~> Store the values from the range in an array ThisAr = .Range("A2:F" & Lrow).Value '~~> Define your new array ReDim ThatAr(1 To Col, 1 To 4) '~~> Loop through the array and store values in new array For i = LBound(ThisAr) To UBound(ThisAr) k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) '~~> Check for Color 1 If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4) '~~> Check for Color 2 If ThisAr(i, 5) <> "" Then k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) ThatAr(k, 4) = ThisAr(i, 5) End If '~~> Check for Color 3 If ThisAr(i, 6) <> "" Then k = k + 1 ThatAr(k, 1) = ThisAr(i, 1) ThatAr(k, 2) = ThisAr(i, 2) ThatAr(k, 3) = ThisAr(i, 3) ThatAr(k, 4) = ThisAr(i, 6) End If Next i End With '~~> Create headers in Sheet2 Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value '~~> Output the array wsThat.Range("A2").Resize(Col, 4).Value = ThatAr End Sub 

SHEET1

SHEET2