VBA脚本查找工作表1上的列L和工作表2上的列A之间的匹配，然后粘贴工作表3上匹配的行

Dim ii As Long Dim j As Long Dim sheet1LastRow As Long Dim sheet2LastRow As Long sheet1LastRow = Worksheets("Final").Range("L" & Rows.Count).End(xlUp).Row sheet2LastRow = Worksheets("2015new").Range("A" & Rows.Count).End(xlUp).Row For j = 2 To sheet1LastRow For ii = 2 To sheet2LastRow If Worksheets("Final").Cells(j, 1).Value = Worksheets("2015new").Cells(ii, 1).Value Then Worksheets("2015new").Rows(ii & ":" & ii).Copy Sheets("Extract").Range("A65536").End(xlUp).Offset(1) Else End If Next ii Next j 

看了看周围的论坛，并提出了上面的代码，但似乎并没有工作。 它也缓冲了一段时间，然后回来什么也没有。 任何帮助是极大的赞赏。 一些额外的信息，两列都由date组成，并且它们不相同。 （意思是表1有大约100行的date，而表2有20行）

Answer 1

只是寻找速度，这样的事情应该会有很大的帮助：

 Dim chkRng As Variant, runRng As Range, outRng As Range, i As Long chkRng = Worksheets("Final").Range("L1", Worksheets("Final").Range("L" & Rows.Count).End(xlUp)).Value For Each runRng In Worksheets("2015new").Range("A2", Worksheets("2015new").Range("A" & Rows.Count).End(xlUp)) For i = 2 To UBound(chkRng) If chkRng(i, 1) = runRng.Value Then If outRng Is Nothing Then Set outRng = runRng.EntireRow Else Set outRng = Union(outRng, runRng.EntireRow) Exit For End If Next Next If Not outRng Is Nothing Then outRng.Copy Sheets("Extract").Range("A65536").End(xlUp).Offset(1) 

Answer 2

我已经对你的代码做了一些修改，希望对你有帮助。 （未testing）

 Dim ii As Long Dim j As Long Dim sheet1LastRow As Long Dim sheet2LastRow As Long sheet1LastRow = Worksheets("Final").Range("L" & Rows.Count).End(xlUp).Row sheet2LastRow = Worksheets("2015new").Range("A" & Rows.Count).End(xlUp).Row For j = 2 To sheet1LastRow For ii = 2 To sheet2LastRow If Worksheets("Final").Cells(j, 1).Value = Worksheets("2015new").Cells(ii, 1).Value Then Worksheets("2015new").Rows(ii).Copy Sheets("Extract").Range("A65536").End(xlUp).Offset(1,0) Else End If Next ii Next j