CODEWITHSUNDEEP
arraysexcelvbaloops
Andes2016
Andes2016

Reputation: 59

VBA to correctly loop through an array

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

Upvotes: 1

Views: 14023

Answers (3)

user6432984
user6432984

Reputation:

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

Upvotes: 0

user3598756
user3598756

Reputation: 29421

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

Upvotes: 1

ThunderFrame
ThunderFrame

Reputation: 9471

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

Upvotes: 0

Related Questions