VBA loop creating specified number of rows and repeating text

[ktgoodlund]

I need a VBA loop that will create the number of rows and repeat the text in column A, for example (animal in A, quantity of rows in B):

Cat 4
Dog 3
Horse 2

Desired result:

Cat
Cat
Cat
Cat
Dog
Dog
Dog
Horse
Horse

For possibly hundreds of lines.

Thanks!

 

[lrobbo314]

How about this?

ExpandRange.xlsm
	A	B	C
1	Cat 4		Cat
2	Dog 3		Cat
3	Horse 2		Cat
4			Cat
5			Dog
6			Dog
7			Dog
8			Horse
9			Horse
Sheet10

Sub AREP()
Dim r As Range:         Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim SP() As String

With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(AR)
        SP = Split(AR(i, 1), " ")
        For j = 1 To SP(1)
            .Add SP(0)
        Next j
    Next i
    Set r = r.Offset(, 2).Resize(.Count)
    r.Value2 = Application.Transpose(.ToArray)
End With
End Sub

 

[lrobbo314]

I missed that you had the values separated into 2 columns.

Sub AREP()
Dim r As Range:         Set r = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2

With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(AR)
        For j = 1 To AR(i, 2)
            .Add AR(i, 1)
        Next j
    Next i
    r.Offset(, 3).Resize(.Count, 1).Value2 = Application.Transpose(.ToArray)
End With
End Sub

 

[Joe4]

Welcome to the Board!

Here is another way:

Sub MyInsertRows()

    Dim lr As Long
    Dim r As Long
    Dim n
    
    Application.ScreenUpdating = False
    
'   Find last row with data in column A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through all rows backwards
    For r = lr To 1 Step -1
'       Get number of rows to insert from column B
        n = Cells(r, "B")
'       Insert rows, if necessary
        If n > 1 Then
'           Insert blank rows
            Cells(r + 1, "A").Resize(n - 1, 1).EntireRow.Insert
'           Populate new rows
            Cells(r, "A").Resize(n, 1).Value = Cells(r, "A").Value
        End If
    Next r
    
'   Clear all of column B
    Columns("B:B").ClearContents

    Application.ScreenUpdating = True

    MsgBox "Macro complete!"

End Sub

 

[lrobbo314]

I know this won't help the OP since version is 2016, but here's the formula way I came up with to do this.

Book1 (version 1).xlsm
	A	B	C	D
1	Cat	4		Cat
2	Dog	3		Cat
3	Horse	2		Cat
4				Cat
5				Dog
6				Dog
7				Dog
8				Horse
9				Horse
Sheet8

Cell Formulas
Range	Formula
D1:D9	D1	=LET(n,B1:B3,INDEX(A1:A3,MATCH(SEQUENCE(SUM(n)),(MMULT(N(ROW(n)>=TRANSPOSE(ROW(n))),n)-INDEX(n,1)+1)+SEQUENCE(COUNT(n),,0),1)))
Dynamic array formulas.