循环可变数据集

Question

根据图片，我希望将每只动物复制到每组/#（并且结果为 Sheet 2）。

目标示例

问题是它不会总是一组 14 个，它可以根据数据而变化，但动物会保持不变（不超过 4 个）。

下面是我的，当然不是基于图片。这是一个例子。

Sub DowithIf()

    rw = 5
    cl = 2
    rw = 1000

    Do While rw < erw
        If Cells(rw, cl) <> Cells(rw - 1, cl) Then
            Cells(rw, cl + 1) = Cells(rw, cl)

            Range("A5:B5").Select
            Selection.Copy
            Sheets("Sheet2").Select
            Range("A2").Select
            ActiveSheet.Paste
            Range("A2:B4").Select
            Application.CutCopyMode = False
            Selection.FillDown
            Sheets("Data").Select
            Range("E3:J5").Select
            Selection.Copy
            Sheets("Sheet2").Select
            Range("C2").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
              :=False, Transpose:=False
        ElseIf Cells(rw, cl) = "" Then
            Exit Do
        End If
        rw = rw + 1
    Loop

End Sub

Answer 1

所以我认为这可以让您动态选择数据集的大小。我假设 headers 列将始终位于第 5 行，如图所示。它循环遍历每个输入列，并在 H、I 和 J 中提供唯一的输出。免责声明：我没有测试这个，因为我不在我的工作电脑上。

Sub MixTheStuff()

'sets size of data in A (Set).  -5 for the header row as noted
x = ThisWorkbook.Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row - 5  
 
'sets size of data in B (#)
y = ThisWorkbook.Sheets("Data").Cells(Rows.Count, 2).End(xlUp).Row - 5

'sets size of data in E (Animal)
z = ThisWorkbook.Sheets("Data").Cells(Rows.Count, 5).End(xlUp).Row - 5   

i=6 'First row after the headers

For sThing = 1 to x    'set thing
For nThing = 1 to y    'number thing
For aThing = 1 to z    'animal thing

    'Pastes the value of the stuff (Set, #, and Animal respectively)
    ThisWorkbook.Sheets("Data").cell(i,10) = ThisWorkbook.Sheets("Data").cell(x,1).value
    ThisWorkbook.Sheets("Data").cell(i,11) = ThisWorkbook.Sheets("Data").cell(y,2).value
    ThisWorkbook.Sheets("Data").cell(i,12) = ThisWorkbook.Sheets("Data").cell(z,5).value

i = i + 1 'Go to the next output row

Next sThing
Next nThing
Next aThing

End Sub

Answer 2

有点逆轴

这将使您最多可以处理 1023 只动物。

代码

Option Explicit

Sub SortOfUnpivot()
    
    Const FirstRow As Long = 6
    Const LastRowCol As String = "E"
    Const dstFirstCell As String = "H6"
    Dim srcCols As Variant
    srcCols = VBA.Array("A", "B", "E")
    
    Dim LB As Long
    LB = LBound(srcCols)
    Dim UB As Long
    UB = UBound(srcCols)
    Dim srcCount As Long
    srcCount = UB - LB + 1
    
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, LastRowCol).End(xlUp).Row
    Dim rng As Range
    Set rng = Cells(FirstRow, LastRowCol).Resize(LastRow - FirstRow + 1)
    Dim Source As Variant
    ReDim Source(LB To UB)
    
    Dim j As Long
    For j = LB To UB
        Source(j) = rng.Offset(, Columns(srcCols(j)).Column - rng.Column).Value
    Next j
    
    Dim UBS As Long
    UBS = UBound(Source(UB))
    
    Dim Dest As Variant
    ReDim Dest(1 To UBS ^ 2, 1 To srcCount)
    Dim i As Long
    Dim k As Long
    
    For j = 1 To UBS
        k = k + 1
        For i = 1 + (j - 1) * UBS To UBS + (j - 1) * UBS
            Dest(i, 1) = Source(0)(k, 1)
            Dest(i, 2) = Source(1)(k, 1)
            Dest(i, 3) = Source(2)(i - (j - 1) * UBS, 1)
        Next i
    Next j
    
    Range(dstFirstCell).Resize(UBound(Dest), srcCount).Value = Dest
    
    
End Sub

Answer 3

如果您将 VBA 看作一种编程语言而不是宏记录器，我想您会发现这更容易。在您的示例中，任务实际上只是创建一个行数为：

的数组

number of set names * number of set items

您需要做的就是按照特定模式填充该数组。在您的示例中，它将是：

set number n with all set items, set number n + 1 with all set items, etc.

骨架代码看起来像这样：

Const SET_NAMES_ROW_START As Long = 6
Const SET_ITEMS_ROW_START As Long = 6
Const SET_NAMES_COL As String = "A"
Const SET_ITEMS_COL As String = "E"
Const OUTPUT_ROW_START As Long = 6
Const OUTPUT_COL As String = "G"

Dim names() As Variant, items() As Variant, output() As Variant
Dim namesCount As Long, itemsCount As Long
Dim idx As Long, nameIdx As Long, itemIdx As Long

'Read the set values.
With Sheet1
    names = .Range( _
                .Cells(SET_NAMES_ROW_START, SET_NAMES_COL), _
                .Cells(.Rows.Count, SET_NAMES_COL).End(xlUp)) _
               .Resize(, 2).Value2
    items = .Range( _
                .Cells(SET_ITEMS_ROW_START, SET_ITEMS_COL), _
                .Cells(.Rows.Count, SET_ITEMS_COL).End(xlUp)) _
               .Value2
End With

'Dimension the output array.
namesCount = UBound(names, 1)
itemsCount = UBound(items, 1)

ReDim output(1 To namesCount * itemsCount, 1 To 3)

'Populate the output array.
nameIdx = 1
itemIdx = 1
For idx = 1 To namesCount * itemsCount
    output(idx, 1) = names(nameIdx, 1)
    output(idx, 2) = names(nameIdx, 2)
    output(idx, 3) = items(itemIdx, 1)
    itemIdx = itemIdx + 1
    If itemIdx > itemsCount Then
        'Increment the name index by 1.
        nameIdx = nameIdx + 1
        'Reset the item index to 1.
        itemIdx = 1
    End If
Next

'Write array to the output sheet.
Sheet1.Cells(OUTPUT_ROW_START, OUTPUT_COL).Resize(UBound(output, 1), UBound(output, 2)).Value = output

循环可变数据集

Looping with variable data set

excel

vba

loops

unpivot

有点逆轴