Looping with variable data set

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).

Example of Goal

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 have, granted it is not based on the picture. That is an 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

Solution

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