My VBA is only copying the last row of data instead of all the rows

[karl10220]

I am trying to get this macro to loop through multiple rows of data and spit out in a new format in a new sheet. However, with a small subet of 5 rows, it is only showing me the last row. Each row on the data sheet should turn into 7 rows on the output sheet. Does anything stand out below?

Sub New_Part_BPA()

Dim r As Integer, q As Integer, lr As Integer

With Worksheets("New BPA")
.Range("E2:R" & .[F1].End(xlDown).Row).ClearContents 'remove current data from sheet 2


For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row 'llop thur all itesm

lr = .Cells(Rows.Count, "F").End(xlUp).Row 'last ro w in sheet 2 with data

For q = 1 To 7 'loop thru all quantities

.Cells(lr + q, "E") = Cells(r, "B") 'supplier
.Cells(lr + q, "L") = Cells(r, "C") 'item
.Cells(lr + q, "N") = Round(Cells(r, 26 + q * 2), 4) 'this will round to 4 places 'price - starte at column AB
.Cells(lr + q, "Q") = Cells(r, "A") 'store
.Cells(lr + q, "R") = Cells(r, 11 + q * 2) ' quantity- starts at column m

Next q

Next r

End With
End Sub

 

[karl10220]

Post 18 worked! It took a long time, though. Is there anything to make it go faster? This code could eventually have 3000 lines and for the 6 here it took around 5 minutes.

 

[MARK858]

It is probably the double loop shina67 posted taking the time to execute, it can be be sped up by putting the results into an array but it isn't something I have time to write as I am just knocking off so I'm ready for work tomorrow.

If no-one else posts anything then I'll have a look at it at the weekend

 

[Alex Blakenburg]

This is the code from Post #18 converted to using arrays.
To test this properly I would need some sample data from both sheets.
Eg I am assuming the output sheet has a heading in Row 1

Sub New_Part_BPA2_Mod()

    Dim r As Long, q As Integer, lr As Long
    Dim lrData As Long, lcData As Long
    Dim wsData As Worksheet
    Dim wsOutput As Worksheet
    Dim rngData As Range, rngOut As Range
    Dim arrData As Variant, arrOut

    Set wsData = ThisWorkbook.Worksheets("New Parts") ' Change "Data" to the name of your data sheet
    Set wsOutput = ThisWorkbook.Worksheets("New BPA")
    
    With wsData
        lcData = .Cells(1, .Columns.Count).End(xlUp).Column
        lrData = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rngData = .Range(.Cells(1, 1), .Cells(lrData, lcData))
        arrData = rngData.Value2
    End With
    
    With wsOutput
        lr = .Columns("E:R").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        If lr = 1 Then lr = 2
        .Range("E2:R" & lr).ClearContents
        Set rngOut = .Cells(2, "E")
    End With
        
    ' Column references based on 1 being Column E
    Dim outSupp As Long, outItem As Long, outPrice As Long, outStore As Long, outQty As Long
    outSupp = 1
    outItem = 8
    outPrice = 10
    outStore = 13
    outQty = 14
    
    ReDim arrOut(1 To lrData * 7, 1 To outQty)
    lr = 0
    For r = 2 To UBound(arrData)                                        ' Loop through all items in data sheet
        For q = 1 To 7                                                  ' Loop through all quantities
            lr = lr + 1                                                 ' Increment row in output sheet
            arrOut(lr, outSupp) = arrData(r, 2)                         ' Supplier
            arrOut(lr, outItem) = arrData(r, 3)                         ' Item
            arrOut(lr, outPrice) = Round(arrData(r, 26 + q * 2), 4)    ' Price
            arrOut(lr, outStore) = arrData(r, 1)                        ' Store
            arrOut(lr, outQty) = arrData(r, 11 + q * 2)                 ' Quantity
        Next q
    Next r
    
    rngOut.Resize(lr, UBound(arrOut, 2)).Value2 = arrOut
End Sub

 

[karl10220]

Holy moly that only took like 0.2 seconds! Thank you!

 

[Alex Blakenburg]

Haha. That's why @MARK858 suggested converting it to using an array.
Accessing the spreadsheet is one of the things that slows VBA down, so reading & wrting cell by cell is pretty slow. When you use arrays you can generally do a single read to get your data and a single write to put it back. This is much faster.
The downside is that when you write the data back, its the equivalent to a PasteSpecial Values, so you lose any formulas or specific formatting you wanted to keep. (whole column formatting is easy enough to put back)