VBA Code: Copy rows based on cell condition, paste rows below and repeat x number of times.

Question

Hi All

I am having some problems with creating a Macro.

I have created some quick tables with dummy data to illustrate my problem.

In the table below, I wish to select all rows in which a 'Yes' can be seen in column A. Hence, in this case the macro would select rows 11 to 14. These rows should then be copied.                                                                                                                     

Number of Repetitions	4
Repetition	Details
No	alpha
No	bravo
No	charlie
No	delta
No	echo
No	foxtrot
No	golf
Yes	hotel
Yes	indigo
Yes	juliet
Yes	kilo

I would then like to take these copied rows and paste them immediately below in the same table. I would like to repeat this paste until it has been repeated to the number specified (in this case, 4 times). This should produce the following table:

Number of Repetitions	4
Repetition	Details
No	alpha
No	bravo
No	charlie
No	delta
No	echo
No	foxtrot
No	golf
Yes	hotel
Yes	indigo
Yes	juliet
Yes	kilo
Yes	hotel
Yes	indigo
Yes	juliet
Yes	kilo
Yes	hotel
Yes	indigo
Yes	juliet
Yes	kilo
Yes	hotel
Yes	indigo
Yes	juliet
Yes	kilo

As can be seen the data has been pasted in the same order as before (hotel --> indigo --> juliet --> kilo), and each of these rows occurs 4 times.

Any help on this is very much appreciated. If you have any questions about what I require then I will gladly answer.

Many Thanks

Lewis

Answer 1

Option Explicit

Sub Test()

  Dim All As Range, Dest As Range

  Dim i As Long

  'Find all "Yes" in column A

  Set All = FindAll(Columns("A"), "Yes")

  'Found?

  If All Is Nothing Then Exit Sub

  'Expand to the entire row

  Set All = All.EntireRow

  'Repeat

  For i = 1 To Range("B1") - 1

    'Find next empty row at the bottom

    Set Dest = Range("A" & Rows.Count).End(xlUp).Offset(1)

    'Copy

    All.Copy Dest

  Next

End Sub

Private Function FindAll(ByVal Where As Range, ByVal What, _

    Optional ByVal After As Variant, _

    Optional ByVal LookIn As XlFindLookIn = xlValues, _

    Optional ByVal LookAt As XlLookAt = xlWhole, _

    Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _

    Optional ByVal SearchDirection As XlSearchDirection = xlNext, _

    Optional ByVal MatchCase As Boolean = False, _

    Optional ByVal SearchFormat As Boolean = False) As Range

  'Find all occurrences of What in Where (Windows version)

  Dim FirstAddress As String

  Dim c As Range

  'From FastUnion:

  Dim Stack As New Collection

  Dim Temp() As Range, Item

  Dim i As Long, j As Long

  If Where Is Nothing Then Exit Function

  If SearchDirection = xlNext And IsMissing(After) Then

    'Set After to the last cell in Where to return the first cell in Where in front if _

      it match What

    Set c = Where.Areas(Where.Areas.Count)

    'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet

    'Set After = C.Cells(C.Cells.Count)

    Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))

  End If

  Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _

    SearchDirection, MatchCase, SearchFormat:=SearchFormat)

  If c Is Nothing Then Exit Function

  FirstAddress = c.Address

  Do

    Stack.Add c

    If SearchFormat Then

      'If you call this function from an UDF and _

        you find only the first cell use this instead

      Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _

        SearchDirection, MatchCase, SearchFormat:=SearchFormat)

    Else

      If SearchDirection = xlNext Then

        Set c = Where.FindNext(c)

      Else

        Set c = Where.FindPrevious(c)

      End If

    End If

    'Can happen if we have merged cells

    If c Is Nothing Then Exit Do

  Loop Until FirstAddress = c.Address

  'FastUnion algorithm © Andreas Killer, 2011:

  'Get all cells as fragments

  ReDim Temp(0 To Stack.Count - 1)

  i = 0

  For Each Item In Stack

    Set Temp(i) = Item

    i = i + 1

  Next

  'Combine each fragment with the next one

  j = 1

  Do

    For i = 0 To UBound(Temp) - j Step j * 2

      Set Temp(i) = Union(Temp(i), Temp(i + j))

    Next

    j = j * 2

  Loop Until j > UBound(Temp)

  'At this point we have all cells in the first fragment

  Set FindAll = Temp(0)

End Function