根据第一张工作表中列的非空单元格，将特定的行范围复制到另一张工作表的特定范围

Question

Hi this is my first post so forgive me for any inconvenience , also I am noob with VBA code. I have sheet "alvin" from which I want to take certain row range if there is a value in column Q and paste it to another sheet called "order template" . I tried the following code but instead of transferring the right rows it transfers rows based on Q cells value . Eg if cell Q5 has 10 the code transfers the 10th row instead of 5th...

Sub test_TRANSFER_to_Order_template()

Application.ScreenUpdating = False

Dim ws1 As Worksheet
Set ws1 = Worksheets("ALVIN")
Dim ws2 As Worksheet
Set ws2 = Worksheets("order template")
Dim q As Range
Dim LRow As Long
LRow = ws2.Range("b" & Rows.Count).End(xlUp).Row + 0
Dim m As Long

For Each q In Range("q4", Range("q1500").End(xlUp))
    If Not IsEmpty(q) Then
        LRow = LRow + 1
        ws2.Range("b" & LRow).Value = ws1.Range("l" & q).Value
        ws2.Range("c" & LRow).Value = ws1.Range("m" & q).Value
        ws2.Range("d" & LRow).Value = ws1.Range("n" & q).Value   'part number
        ws2.Range("e" & LRow).Value = ws1.Range("q" & q).Value
        ws2.Range("f" & LRow).Value = ws1.Range("r" & q).Value

        Application.ScreenUpdating = True
    End If
Next

End Sub

Answer 1

As q is defined as a Range , and you are trying to get the row number, you need to modify it to q.Row .

For instance,

ws2.Range("b" & LRow).Value = ws1.Range("l" & q).Value

Should be:

ws2.Range("b" & LRow).Value = ws1.Range("l" & q.Row).Value

and so on for the rest of them...

---

Edit : to make sure you are checking the right values, it's better if you fully qualify your range with the sheet Worksheets("ALVIN") .

Modified Loop

With ws1 ' <-- qualify the range with "ALVIN" worksheet
    For Each q In .Range("Q4", .Range("Q1500").End(xlUp))
        If Not IsEmpty(q) Then
            LRow = LRow + 1
            ws2.Range("b" & LRow).Value = .Range("l" & q.Row).Value
            ws2.Range("c" & LRow).Value = .Range("m" & q.Row).Value
            ws2.Range("d" & LRow).Value = .Range("n" & q.Row).Value   'part number
            ws2.Range("e" & LRow).Value = .Range("q" & q.Row).Value
            ws2.Range("f" & LRow).Value = .Range("r" & q.Row).Value

            Application.ScreenUpdating = True
        End If
    Next q
End With