excel宏(VBA)将多个列转置到多个行 [英] excel macro(VBA) to transpose multiple columns to multiple rows
问题描述
这种转型是我试图执行的。只是为了说明我已经把它作为表。因此,基本上第3列应重复有多少颜色可用。
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开始,但没有帮助
另一个例如与两个不同的集合:
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
UnPivot功能:
UnPivot function:
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
这篇关于excel宏(VBA)将多个列转置到多个行的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!