使用VBA将多列转置为多行 [英] Transpose multiple columns to multiple rows with VBA
问题描述
我正在尝试执行这种转换.为了便于说明,我将其作为表格进行了说明,因此基本上应该重复前三列以提供多少种可用颜色.
This kind of transformation is what I was trying to perform. Just for illustration I have made this as table.So basically the first 3 column should repeat for how many ever colors are available.
我搜索了其他类似的种类,但是当我想重复多列时找不到. 我在网上找到了此代码,但是 姓名谢谢地点谢谢地点谢谢地点谢谢地点 并使其如下所示 名字谢谢位置
I searched for other similar kinds but could not find when I want multiple columns to repeat. I found this code online but it is Name Thank Location Thank Location Thank Location Thank Location and makes it like below 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个不同集的示例:
Could some one help in changing the format I want, I tried changing step 2 to 1 and j to start from 4 but that was not helpful Another eg with 2 varied sets:
推荐答案
这是一种通用的非透视"方法(所有固定"列都必须出现在输入数据的左侧)
Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the input data)
测试子:
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
取消枢纽功能:
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
这篇关于使用VBA将多列转置为多行的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!