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

 

[MARK858]

Try moving lr into the 2nd loop

Change

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

to

For q = 1 To 7 'loop thru all quantities

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

lr and r should also both be Long's as you are using 365 (or any version from 2007)

 

[karl10220]

Thank you! I made that change and it gave error 438; Object doesn't support this property or method.

 

[MARK858]

I can see no reason why that line would give that error by moving it, please post your code as you have it (in code tags please... paste the code, select the code, click the

icon)

 

[karl10220]

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

For q = 1 To 7 'loop thru all quantities

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

.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

 

[MARK858]

My fault, bad copying, it is missing the lr = at the start

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

 

[shina67]

It seems like there might be a couple of issues with your code that could be causing it to only show the last row.

Here's a revised version of your code.

Sub New_Part_BPA()

Dim r As Integer, q As Integer, lr As Integer
Dim wsData As Worksheet
Dim wsOutput As Worksheet

Set wsData = ThisWorkbook.Worksheets("Data") ' Change "Data" to the name of your data sheet
Set wsOutput = ThisWorkbook.Worksheets("New BPA")

With wsOutput
.Range("E2:R" & .Cells(.Rows.Count, "F").End(xlUp).Row).ClearContents ' Clear existing data

lr = .Cells(.Rows.Count, "F").End(xlUp).Row ' Last row in output sheet

For r = 2 To wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row ' Loop through all items in data sheet
For q = 1 To 7 ' Loop through all quantities
lr = lr + 1 ' Increment row in output sheet
.Cells(lr, "E").Value = wsData.Cells(r, "B").Value ' Supplier
.Cells(lr, "L").Value = wsData.Cells(r, "C").Value ' Item
.Cells(lr, "N").Value = Round(wsData.Cells(r, 26 + q * 2).Value, 4) ' Price
.Cells(lr, "Q").Value = wsData.Cells(r, "A").Value ' Store
.Cells(lr, "R").Value = wsData.Cells(r, 11 + q * 2).Value ' Quantity
Next q
Next r
End With

End Sub

Please adjust the worksheet names ("Data" and "New BPA") accordingly to match your actual worksheet names. Additionally, ensure that the columns being referenced (e.g., columns "A", "B", etc.) are correct for your data structure.

 

[karl10220]

Minor issue, but it works. It just clears the top row 'Header' detail of each column, but that's an easy copy/paste solution if it can't be corrected here. Thank you so much!

 

[shina67]

You're welcome!
If the code clears the top row (header) details of each column, you can adjust it to skip the first row when copying data.

For r = 2 To wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row ' Loop through all items in data sheet

This ensures that the code starts copying data from the second row, leaving the header row intact. Seems strange it is doing what you say it is. Try changing the 2 to a 3. If you make this adjustment, the header row should remain unaffected when creating new tabs.

 

[MARK858]

Seems strange it is doing what you say it is.

If column F is empty or only has a header it will clear all the headers, possibly that is what is happening.

.Range("E2:R" & .Cells(.Rows.Count, "F").End(xlUp).Row).ClearContents