复制不同列表中存在的每一行

我会尽量清楚。 我有3张;

• 所有产品
• 名单
• 我们的产品

AllProducts包含所有存在的产品（在某个行业）， List表单包含我们拥有的产品的标识符列表。 如果List存在列A（ AllProducts ）中的值，则我们的产品是需要复制行的目标选项卡。

但是，当sheet1（ Allproducts ）中的值不在列表中时，row3应该在列表中向下一行。 因为有时有多个值不在列表中我的row3variables不断累加…

任何人都知道这个问题或更好的解决scheme？

 Sub CB_Products() Range("I12").Value = Now() 'Time and date the button is clicked/Data retrieved Range("F12").Value = "Done" Application.ScreenUpdating = False 'Prevents screenupdating Dim row1 As Long 'The row number where it needs to be copied from (sheet1) Dim row2 As Long 'The row number it needs to be pasted on (sheet2) Dim row3 As Long 'The row number the original value comes from (sheet3) Dim continue As Boolean 'Define starting rows (Row 1 contains headers usually) row1 = 2 'Rownr of AllProducts row2 = 2 'Rownr of Ourproducts row3 = 2 'Rownr of List continue = True Sheets("AllProducts").Select 'Start loop, look if value in AllProducts sheet is same as list sheet Do While continue = True If Cells(row1, 1).Value = Sheets("List").Range("A" & row3) Then Rows(row1).Select 'If yes, copy Selection.copy Sheets("OurProducts").Select 'If yes, change sheet and paste Rows(row2).Select ActiveSheet.Paste row2 = row2 + 1 'If yes, add rownumber to move downwards row1 = row1 + 1 'If yes, add rownumber to move downwards Sheets("AllProducts").Select If Cells(row1, 1).Value = "" Then continue = False 'If we reach the end (empty cell) then stop the loop If Cells(row3, 1).Value = "" Then continue = False If Cells(row1, 1).Value <> Sheets("List").Range("A" & row3) And Cells(row1 + 1, 1) <> Sheets("List").Range("A" & row3) Then row3 = row3 + 1 Else row1 = row1 + 1 'If the value is not the same and not blank, then go down the list to search for new values End If Loop Application.ScreenUpdating = True End Sub 

我简化了代码，使列表的所有值现在在一个数组中，我一直在挣扎整天创build一个MATCH函数。 但是我没有成功。 当find该值（并且可以多次find该值）。 整行需要被复制到另一张纸上。

 Sub Products_test2() Dim Copycell As Excel.Range Dim ListArray() As String Dim LastList As Long Dim i As Integer 'Finds the last cellnr of List LastList = Sheets("List").Cells(Rows.Count, "A").End(xlUp).Row 'Makes the size of Array as big as list ReDim ListArray(1 To LastList) 'Fills the array with the values from the list For i = 1 To LastList ListArray(i) = Sheets("List").Range("A" & i + 1).Value Next i End Sub