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

 

[shina67]

To avoid accidentally clearing the header row when determining the last row of data in column F, you can modify the code to start from the last row and move upwards until finding the last non-empty cell. Here's how you can adjust that part of the code:

lr = .Cells(.Rows.Count, "F").End(xlUp).Row ' Last row in column F
While lr > 1 And IsEmpty(.Cells(lr, "F")) ' Loop while the cell is empty and not the first row
lr = lr - 1 ' Move up one row
Wend

This modification ensures that the lr variable will be set to the last row containing data in column F, without accidentally including the header row if it's empty. With this adjustment, the header row should remain unaffected even if column F is empty or contains only the header.

 

[karl10220]

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("New Parts") ' 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 column F
While lr > 1 And IsEmpty(.Cells(lr, "F")) ' Loop while the cell is empty and not the first row
lr = lr - 1 ' Move up one row




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

This is giving an error Compile Error: End with without With

I tried adding the latest to skip first row.

 

[shina67]

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("New Parts") ' 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 column F
While lr > 1 And IsEmpty(.Cells(lr, "F")) ' Loop while the cell is empty and not the first row
lr = lr - 1 ' Move up one row
Wend

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 ' <-- This is the missing '
End With' statement
End Sub

I've added the missing End With statement at the end of your code block. This should resolve the compile error, and your code should run without any issues.

 

[karl10220]

Thankyou! I had to remove one of the End With lines to get it to work, and it still removes the top row, but it's such a small issue, the main issue was corrected! So thank you!

 

[MARK858]

@karl10220 does the below adaption of shina67's code resolve the issue?

Sub New_Part_BPA2()

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

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

    With wsOutput
        lr = .Columns("E:R").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        If lr = 1 Then lr = 2
        .Range("E2:R" & lr).ClearContents
 

        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

 

[karl10220]

Thank you for this. This one keeps the row headers, but doesn't transfer any of the data!

 

[MARK858]

That seems strange as there is nothing changed other than how it defines lr.
What number does the message box give you if you run the code below?

Sub New_Part_BPA2()
    Dim lr As Long
    Dim wsOutput As Worksheet

    Set wsOutput = ThisWorkbook.Worksheets("New BPA")

    With wsOutput
        lr = .Columns("E:R").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        If lr = 1 Then lr = 2
    End With

    MsgBox lr

End Sub

 

[MARK858]

Also does the below make a difference (test on a copy)

Sub New_Part_BPA2()

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

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

    With wsOutput
        lr = .Columns("E:R").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        If lr = 1 Then lr = 2
        .Range("E2:R" & lr).ClearContents
        
        lr = .Columns("E:R").Find("*", , xlValues, , xlByRows, xlPrevious).Row

        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

 

[karl10220]

That seems strange as there is nothing changed other than how it defines lr.
What number does the message box give you if you run the code below?

Sub New_Part_BPA2()
    Dim lr As Long
    Dim wsOutput As Worksheet

    Set wsOutput = ThisWorkbook.Worksheets("New BPA")

    With wsOutput
        lr = .Columns("E:R").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        If lr = 1 Then lr = 2
    End With

    MsgBox lr

End Sub

169

 

[MARK858]

And no data got put into row 170 (I know that isn't where you want the data, I just want to know if it went there)? also test post 18 please on a copy