1

I have read through a number of summaries of arrays but I am still lost and looking for much appreciated help. I have successfully created a non-array macro that copies a row in my ws and places below that parent row three copies. It does this for every row in the ws.

eg

From:

ColA     ColB
Tom      Tent
Barry    Stove

To:

ColA     ColB
Tom      Tent
Tom      Tent
Tom      Tent
Tom      Tent
Barry    Stove
Barry    Stove
Barry    Stove
Barry    Stove

There are > 4000 rows to loop through. My code works fine but it is slow. So I read that placing the ws into an array is better and then loop through the array. Here is where I am lost with arrays; how do I execute this copy and paste x 3 when I bring the ws into an array? I have written some code below but not sure how to execute this further. Many thanks.

Sub LoadDataintoArray()

Dim StrArray As Variant
Dim TotalRows As Long



TotalRows = Rows(Rows.Count).End(xlUp).Row
StrArray = Range(Cells(1, 1), Cells(TotalRows, 1)).Value

MsgBox "Loaded " & UBound(StrArray) & " items!"

'HERE I NOW WISH TO COPY EACH ROW IN THE WS (EXCEPT HEADER) AND PASTE THREE COPIES OF THAT ROW IMMEDIATELY BELOW THE PARENT ROW

'CODE I USED NOT USNG AN ARRAY IS BELOW
'
'    lRow = 2
'    Do While (Cells(lRow, "B") <> "")
'
'        RepeatFactor = 4
'
'        Range(Cells(lRow, "A"), Cells(lRow, "G")).Copy
'
'        Range(Cells(lRow + 1, "A"), Cells(lRow + RepeatFactor - 1, "G")).Select
'
'        Selection.Insert Shift:=xlDown
'
'           lRow = lRow + RepeatFactor - 1
'
'        lRow = lRow + 1
'    Loop
'

End Sub
Improve this question

3 Answers 3

Reset to default
1

you could try this

Option Explicit
Sub Main()
    Dim Data As Variant
    Dim x As Long

    With Range("A2:G2", Range("B" & Rows.count).End(xlUp))
        Data = .Value
        For x = 1 To UBound(Data, 1)
            .Rows(4 * (x - 1) + 1).Resize(4) = Application.index(Data, x, 0)
        Next
    End With
End Sub

which exploits this trick I knew from Thomas Inzina

Improve this answer
Sign up to request clarification or add additional context in comments.

8 Comments

Many thanks for sharing. This works but gives three rows. Can you please explain where to modify to give four rows?
I think I learned how to modify to give four rows: Rows(4 * (x - 1) + 1).Resize(4) = Application.index(Data, x, 0). Correct? Can you explain what is going on in this last?
You are welcome and correct: Rows(4 * (x - 1) + 1).Resize(4) = Application.index(Data, x, 0) will copy four times (I'll edit the answer). As for the explanation: 1) .Rows(3 * (x - 1) + 1) references every third row of referenced range (Range("A2:G2", Range("B" & Rows.count).End(xlUp)): row 1, 4, 7 ... 2).Resize(3) extends it to span three rows. 3) Application.index(Data, x, 0) takes Data array xth row and assigns it to the three rows range . Finally you may want to mark answer as accepted, thank you!
Thanks for the Plug...lol. +1 because I like the by far the easiest to read and modify.
@ThomasInzina, BTW did you ever succeed in having that trick of the year really write more than one row (or column) out of an array in one shot?
|
0

Reading arrays is somewhat faster than reading cell values. The real performance gain is writing the data back to the worksheet.

As always I recommend watching Excel VBA Introduction on Youtube. This is the relevant video: Part 25 - Arrays 

Sub RepeatData()
    Dim Data As Variant, Data1 As Variant
    Dim x As Long, x1 As Long, x2 As Long, y As Long

    Data = Range("A2:G2", Range("B" & Rows.Count).End(xlUp))
    ReDim Data1(1 To UBound(Data, 1) * 4, 1 To UBound(Data, 2))

    For x = 1 To UBound(Data, 1)
        For x1 = 1 To 4
            x2 = x2 + 1
            For y = 1 To UBound(Data, 2)
                Data1(x2, y) = Data(x, y)
            Next
        Next
    Next

    Range("A2:G2").Resize(UBound(Data1, 1)).Value = Data1

End Sub
Improve this answer

4 Comments

Many thanks for sharing. This added four additional rows where I need three; not sure where to amend the code just to add three. Thanks.
Thomas, yes I did try it and it works. As I need four rows I am just not there yet on reading the code and knowing how to modify it to get four rows. I played with it by trial and error...more on the error side. Thanks.
@Andes2016 sorry that I miss read your question and comment. Happy coding!
Thanks for modifying! Works great.
0

This code will be more flexible should you decide to alter the number of repetitions, or the number of columns that you want to have repeat with each row.

Sub test1()

  'Set your input range to include all of the rows and all of the columns to repeat
  Dim StrArray As Variant
  StrArray = Range("A2:B5")

  Const numRepeats As Long = 4
  Const outputColumnStart As Long = 4

  Dim rowCounter As Long
  Dim colCounter As Long

  'Dimension a new array and populate it
  ReDim newArray(LBound(StrArray, 1) To UBound(StrArray, 1) * numRepeats, LBound(StrArray, 2) To UBound(StrArray, 2))

  For rowCounter = LBound(StrArray, 1) To UBound(StrArray, 1)
    Dim repeatCounter As Long
    For repeatCounter = 0 To numRepeats - 1
      For colCounter = LBound(StrArray, 2) To UBound(StrArray, 2)
        newArray(((rowCounter - 1) * numRepeats + 1) + repeatCounter, colCounter) = StrArray(rowCounter, colCounter)
      Next colCounter
    Next
  Next rowCounter

  'Write the values to the sheet in a single line.
  With ActiveSheet
    .Range(.Cells(1, 4), .Cells(UBound(newArray, 1), outputColumnStart + UBound(newArray, 2) - 1)).Value = newArray
  End With
End Sub
Improve this answer

1 Comment

Thanks for sharing and for the explanations in your code.

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.