VBA to copy and paste a list over and over

[Cr864]

Hi, im looking for some VBA code to be able to take the data in Column A and Paste it in a column, a number of times equal to its value in column B. I need the output to look like the second xl2BB sheet below. It's important that the data goes in order from top to bottom each time it is posted, and that the data in column A only shows up a number of times equal to its value in column B.


Thank you for any help!

Auto200.xlsm
	A	B
6	A	1
7	B	2
8	C	3
9	D	4
10	E	5
11	F	6
Variables

Auto200.xlsm
	D
6	A
7	B
8	C
9	D
10	E
11	F
12	B
13	C
14	D
15	E
16	F
17	C
18	D
19	E
20	F
21	D
22	E
23	F
24	E
25	F
26	F
Variables

 

[Anthony47]

Try this macro:

Sub KeepCopying()
Dim LastA As Long, I As Long, Rpt As Long
Dim Dest As String, NextG As Long
'
Dest = "H5"              '<<< The position for the resulting list
'
LastA = Cells(Rows.Count, "A").End(xlUp).Row
Do
    Rpt = 0
    NextG = Range(Dest).Offset(10000, 0).End(xlUp).Row
    If NextG < Range(Dest).Row Then NextG = 0 Else NextG = NextG - Range(Dest).Row + 1
'    Cells(Rows.Count, OCol).End(xlUp).Row 1
    For I = 1 To LastA
        If Application.WorksheetFunction.CountIf(Range(Dest).Resize(1 + NextG + Rpt, 1), Cells(I, "A")) < Cells(I, "B").Value Then
            Range(Dest).Offset(NextG + Rpt, 0).Value = Cells(I, "A")
            Rpt = Rpt + 1
        End If
    Next I
    If Rpt = 0 Then Exit Do
    DoEvents
Loop
End Sub

Adapt the line marked <<< to your preference

Bye

 

[Cr864]

Try this macro:

Sub KeepCopying()
Dim LastA As Long, I As Long, Rpt As Long
Dim Dest As String, NextG As Long
'
Dest = "H5"              '<<< The position for the resulting list
'
LastA = Cells(Rows.Count, "A").End(xlUp).Row
Do
    Rpt = 0
    NextG = Range(Dest).Offset(10000, 0).End(xlUp).Row
    If NextG < Range(Dest).Row Then NextG = 0 Else NextG = NextG - Range(Dest).Row + 1
'    Cells(Rows.Count, OCol).End(xlUp).Row 1
    For I = 1 To LastA
        If Application.WorksheetFunction.CountIf(Range(Dest).Resize(1 + NextG + Rpt, 1), Cells(I, "A")) < Cells(I, "B").Value Then
            Range(Dest).Offset(NextG + Rpt, 0).Value = Cells(I, "A")
            Rpt = Rpt + 1
        End If
    Next I
    If Rpt = 0 Then Exit Do
    DoEvents
Loop
End Sub

Adapt the line marked <<< to your preference

Bye

This works great!

Thank you!

 

[Anthony47]

thank you for the feedback

 

[Cr864]

thank you for the feedback

Is there an easy way to filter the destination range and only copy these into the visible cells after the filtering is done? I tried turning on an autofilter for the term im looking for, but it was copying into non visible cells as well.

Thanks Anthony!

 

[Anthony47]

The copied range can be non-contiguous cells, but the pasted range will be of contiguous cells.

Try explaining further wich is the need and maybe a solution will be found

Bye