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

Question

我会尽量保持清醒。我有3张纸;

• AllProducts
• 列表
• Ourproducts

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

但是，如果列表中不存在sheet1（Allproducts）中的值，则row3应该在列表中的一行中向下。因为有时候列表中没有多个值，所以我的row3变量不断加起来......

有人知道问题或更好的解决方案吗？

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

我已经简化了代码，以便列表的所有值现在都在一个数组中，我一整天都在努力创建MATCH函数。但是我没有成功。找到值时（可以多次找到该值）。整行需要复制到另一张表。

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