If values match in different worksheets, loop to copy range to new blank worksheet.

Question

I review Stack Overflow almost daily to improve my VBA capabilities, when I find an interesting question, I try to construct a macro that will accomplish the task.

My code below does what I want, it loops through Sheet2, column "K" and searches for a match in Sheet1, column "A".

When a match is found, the code selects the cell in Sheet2, column "K", resizes 5 cells to the right and copies the range to a blank Sheet3, Column A.

To get each range to paste into a new row on Sheet3, I had to add an .Offset(1) on the Destination:= line.

Without the Offset the code just overwrites the data on row 1.

But, using the Offset the code starts writing the data on row 2.

My cheep fix was to just delete row 1.

I'm stuck, is there a way to fix my code, so it starts pasting the range of data on row 1? Code is below;

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")

Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long

lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To lRow1
    For j = 1 To lRow2
        If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
            'The part below does what I want it to do, except it skips row 1.
            'If I remove the "Offset.(1)" it just overwrites the data in row 1.
            ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    Next j
Next i

ws3.Rows(1).Delete 'My cheep fix is to delete row 1, which is blank, to get the data to start on row 1.

End Sub

GMalc GMalc · Accepted Answer · 2017-08-14T03:42:40

Just encase anyone want to know how I resolved my issue.

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim r As Integer

Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")


Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long

lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

r = 1

For i = 1 To lRow1
    For j = 1 To lRow2
        If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
            ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Cells(r, 1)

        r = r + 1

        End If
    Next j
Next i

If values match in different worksheets, loop to copy range to new blank worksheet.

1 Answers