excel宏(VBA)将多个列转置到多个行 [英] excel macro(VBA) to transpose multiple columns to multiple rows

查看:548
本文介绍了excel宏(VBA)将多个列转置到多个行的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!

问题描述

这种转型是我试图执行的。只是为了说明我已经把它作为表。因此,基本上第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屋!

查看全文
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆