查找多个字符串，复制整行并粘贴到另一个工作表中

Question

第一次发帖，如有错误请见谅。 我正在处理一个 excel 项目，我需要一个宏来在工作表上查找某些名称，一旦找到所述名称就复制整行并将其粘贴到另一个工作表上。 我设法编写了一个代码来查找其中一个名称，然后复制该行并将其粘贴到另一张纸上。 我的问题是：有没有什么办法可以让它循环遍历一个名字列表并一个一个地检查它们，而不是一个名字？

我的代码如下：

Sub Macro2()

Dim StatusCol As Range
Dim Status As Range
Dim PasteCell As Range

Set StatusCol = Sheet10.Range("A1:AV1569")

For Each Status In StatusCol
    If Sheet11.Range("A2") = "" Then
        Set PasteCell = Sheet11.Range("A2")
    Else
        Set PasteCell = Sheet11.Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    If Status = "Jane Thompson" Then Status.Offset(0, -4).Resize(1, 5).Copy PasteCell
    
Next Status
        
End Sub

因此，不是只找到一个字符串，即“Jane Thompson”名称，我希望它遍历名称列表，找到每个名称，复制它们所在的整行并将该行粘贴到另一张纸中，但是我不知道该怎么做。 我在另一个工作表上有所有名字（大约 80 个不同的名字）

任何帮助将不胜感激。

谢谢！

编辑：

我设法找到了一个代码，可以给我所需的输出：

Sub FruitBasket()


Dim rngCell As Range
Dim lngLstRow As Long
Dim strFruit() As String
Dim intFruitMax As Integer


intFruitMax = 3
ReDim strFruit(1 To intFruitMax)


strFruit(1) = "Fruit 2"
strFruit(2) = "Fruit 5"
strFruit(3) = "Fruit 18"


lngLstRow = ActiveSheet.UsedRange.Rows.Count


For Each rngCell In Range("A2:A" & lngLstRow)
    For i = 1 To intFruitMax
        If strFruit(i) = rngCell.Value Then
            rngCell.EntireRow.Copy
                Sheets("Inventory").Select
                    Range("A65536").End(xlUp).Offset(1, 0).Select
                    Selection.PasteSpecial xlPasteValues
                Sheets("Fruit").Select
        End If
    Next i
Next


End Sub

但不是数组中的 3 个项目，我不得不硬编码 81 个名称。 有没有办法从另一张表中提取数组的项目，所以我不必对它们进行硬编码？ 提前致谢！

Answer 1

使用数组中的名称，您可以使用Match而不是循环遍历它们。

Option Explicit

Sub FruitBasket()

    Dim ws As Worksheet, wsInv As Worksheet
    Dim rngCell As Range, v As Variant, arNames
    Dim lngLastRow As Long, lngInvRow As Long
 
    With Sheets("Names")
        lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        arNames = .Range("A2:A" & lngLastRow)
    End With
     
    Set wsInv = Sheets("Inventory")
    With wsInv
        lngInvRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    With ws
        lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
     
        For Each rngCell In .Range("A2:A" & lngLastRow)
            ' check if value is in array
            v = Application.Match(rngCell, arNames, 0)
            If IsError(v) Then
                ' no match
            Else
                ' match
                rngCell.EntireRow.Copy
                lngInvRow = lngInvRow + 1
                wsInv.Cells(lngInvRow, "A").PasteSpecial xlPasteValues
            End If
        Next
        
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Done"
    
End Sub