如果值在不同的工作表中匹配，则循环以将范围复制到新的空白工作表。

Question

我几乎每天都查看 Stack Overflow 以提高我的 VBA 功能，当我发现一个有趣的问题时，我会尝试构建一个可以完成任务的宏。

下面的代码执行我想要的操作，它循环通过 Sheet2，列“K”并在 Sheet1，列“A”中搜索匹配项。

找到匹配项后，代码选择 Sheet2 中的单元格，列“K”，向右调整 5 个单元格的大小并将范围复制到空白 Sheet3，列 A。

要将每个范围粘贴到 Sheet3 上的新行中，我必须在 Destination:= 行上添加一个 .Offset(1)。

如果没有偏移，代码只会覆盖第 1 行的数据。

但是，使用偏移量，代码开始在第 2 行写入数据。

我只是删除第 1 行。

我被卡住了，有没有办法修复我的代码，所以它开始在第 1 行粘贴数据范围？ 代码如下；

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

Answer 1

请包含任何想知道我如何解决问题的人。

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