使用VBA将多列转换为多行

Question

我正在尝试执行这种转换。为了说明起见，我将其列为表格，因此基本上应该重复前三列以提供多少种可用颜色。 

我搜索了其他类似的种类，但是当我想重复多列时找不到。我在网上找到了此代码，但是它是Name Thank Location Thank Location Thank Location Thank Location Thank Location，并使其如下所示。Name Thank Location

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套不同的套：2套不同

Answer 1

这是一种通用的“取消透视”方法（所有“固定”列必须出现在输入数据的左侧）测试子：Sub Tester()&nbsp; &nbsp; Dim p&nbsp; &nbsp; 'get the unpivoted data as a 2-D array&nbsp; &nbsp; p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; 3, False, False)&nbsp; &nbsp; With Sheets("Sheet1").Range("H1")&nbsp; &nbsp; &nbsp; &nbsp; .CurrentRegion.ClearContents&nbsp; &nbsp; &nbsp; &nbsp; .Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet&nbsp; &nbsp; End With&nbsp; &nbsp; 'EDIT: alternative (slower) method to populate the sheet&nbsp; &nbsp; '&nbsp; &nbsp; &nbsp; from the pivoted dataset.&nbsp; Might need to use this&nbsp; &nbsp; '&nbsp; &nbsp; &nbsp; if you have a large amount of data&nbsp; &nbsp; Dim r As Long, c As Long&nbsp; &nbsp; For r = 1 To Ubound(p, 1)&nbsp; &nbsp; For c = 1 To Ubound(p, 2)&nbsp; &nbsp; &nbsp; &nbsp; Sheets("Sheet2").Cells(r, c).Value = p(r, c)&nbsp; &nbsp; Next c&nbsp; &nbsp; Next rEnd Sub取消枢纽功能：Function UnPivotData(rngSrc As Range, fixedCols As Long, _&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;Optional AddCategoryColumn As Boolean = True, _&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;Optional IncludeBlanks As Boolean = True)&nbsp; &nbsp; Dim nR As Long, nC As Long, data, dOut()&nbsp; &nbsp; Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long&nbsp; &nbsp; Dim outRows As Long, outCols As Long&nbsp; &nbsp; data = rngSrc.Value 'get the whole table as a 2-D array&nbsp; &nbsp; nR = UBound(data, 1) 'how many rows&nbsp; &nbsp; nC = UBound(data, 2) 'how many cols&nbsp; &nbsp; 'calculate the size of the final unpivoted table&nbsp; &nbsp; outRows = nR * (nC - fixedCols)&nbsp; &nbsp; outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)&nbsp; &nbsp; 'resize the output array&nbsp; &nbsp; ReDim dOut(1 To outRows, 1 To outCols)&nbsp; &nbsp; 'populate the header row&nbsp; &nbsp; For c = 1 To fixedCols&nbsp; &nbsp; &nbsp; &nbsp; dOut(1, c) = data(1, c)&nbsp; &nbsp; Next c&nbsp; &nbsp; If AddCategoryColumn Then&nbsp; &nbsp; &nbsp; &nbsp; dOut(1, fixedCols + 1) = "Category"&nbsp; &nbsp; &nbsp; &nbsp; dOut(1, fixedCols + 2) = "Value"&nbsp; &nbsp; Else&nbsp; &nbsp; &nbsp; &nbsp; dOut(1, fixedCols + 1) = "Value"&nbsp; &nbsp; End If&nbsp; &nbsp; 'populate the data&nbsp; &nbsp; rOut = 1&nbsp; &nbsp; For r = 2 To nR&nbsp; &nbsp; &nbsp; &nbsp; For cat = fixedCols + 1 To nC&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; If IncludeBlanks Or Len(data(r, cat)) > 0 Then&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; rOut = rOut + 1&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; 'Fixed columns...&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; For c = 1 To fixedCols&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; dOut(rOut, c) = data(r, c)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; Next c&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; 'populate unpivoted values&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; If AddCategoryColumn Then&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; dOut(rOut, fixedCols + 1) = data(1, cat)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; dOut(rOut, fixedCols + 2) = data(r, cat)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; Else&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; dOut(rOut, fixedCols + 1) = data(r, cat)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; End If&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; End If&nbsp; &nbsp; &nbsp; &nbsp; Next cat&nbsp; &nbsp; Next r&nbsp; &nbsp; UnPivotData = dOutEnd Function

Answer 2

这是使用数组的一种方法（最快吗？）。这种方法比链接的问题更好，因为它不会在循环中读写范围对象。我已经注释了代码，因此您在理解它时应该没有问题。Option ExplicitSub Sample()&nbsp; &nbsp; Dim wsThis As Worksheet, wsThat As Worksheet&nbsp; &nbsp; Dim ThisAr As Variant, ThatAr As Variant&nbsp; &nbsp; Dim Lrow As Long, Col As Long&nbsp; &nbsp; Dim i As Long, k As Long&nbsp; &nbsp; Set wsThis = Sheet1: Set wsThat = Sheet2&nbsp; &nbsp; With wsThis&nbsp; &nbsp; &nbsp; &nbsp; '~~> Find Last Row in Col A&nbsp; &nbsp; &nbsp; &nbsp; Lrow = .Range("A" & .Rows.Count).End(xlUp).Row&nbsp; &nbsp; &nbsp; &nbsp; '~~> Find total value in D,E,F so that we can define output array&nbsp; &nbsp; &nbsp; &nbsp; Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))&nbsp; &nbsp; &nbsp; &nbsp; '~~> Store the values from the range in an array&nbsp; &nbsp; &nbsp; &nbsp; ThisAr = .Range("A2:F" & Lrow).Value&nbsp; &nbsp; &nbsp; &nbsp; '~~> Define your new array&nbsp; &nbsp; &nbsp; &nbsp; ReDim ThatAr(1 To Col, 1 To 4)&nbsp; &nbsp; &nbsp; &nbsp; '~~> Loop through the array and store values in new array&nbsp; &nbsp; &nbsp; &nbsp; For i = LBound(ThisAr) To UBound(ThisAr)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; k = k + 1&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 1) = ThisAr(i, 1)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 2) = ThisAr(i, 2)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 3) = ThisAr(i, 3)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; '~~> Check for Color 1&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; '~~> Check for Color 2&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; If ThisAr(i, 5) <> "" Then&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; k = k + 1&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 1) = ThisAr(i, 1)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 2) = ThisAr(i, 2)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 3) = ThisAr(i, 3)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 4) = ThisAr(i, 5)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; End If&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; '~~> Check for Color 3&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; If ThisAr(i, 6) <> "" Then&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; k = k + 1&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 1) = ThisAr(i, 1)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 2) = ThisAr(i, 2)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 3) = ThisAr(i, 3)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ThatAr(k, 4) = ThisAr(i, 6)&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; End If&nbsp; &nbsp; &nbsp; &nbsp; Next i&nbsp; &nbsp; End With&nbsp; &nbsp; '~~> Create headers in Sheet2&nbsp; &nbsp; Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value&nbsp; &nbsp; '~~> Output the array&nbsp; &nbsp; wsThat.Range("A2").Resize(Col, 4).Value = ThatArEnd Sub