Looping with infinite data set

问题

I am trying to create a VBA but I keep getting stuck, if anyone can help that would be appreciated. So based on the picture I would like for each animal to be copied to each Set/# (and for the outcome to be on Sheet 2). The issue is that it won't always be a set of 14 it can vary based on the data but the Animals would stay the same (no more then 4). Below is what i currently have ganted it is not based on the picture. that's is just an example.

Example of Goal for VBA

updated VBA Example

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

回答1:

I think you'd find this easier if you looked at VBA as more of a programming language than a macro recorder. In your example, the task is really just to create an array whose row count is:

number of set names * number of set items

All you'd need to do is populate that array following a certain pattern. In your example it would be:

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

Skeleton code would look something like this:

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

回答2:

So I think this will let you dynamically pick the size of your data set. I'm assuming that the column headers will always be at Row 5 as pictured. It loops through each input column and provides a unique output in H, I, and J. Disclaimer: I didn't get to test this as I'm not on my work PC.

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

回答3:

Sort of Unpivot

This will allow you to handle maximally 1023 animals.

The Code

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

来源：https://stackoverflow.com/questions/64760939/looping-with-infinite-data-set

标签

excel

vba

loops