查找多個字符串，復制整行並粘貼到另一個工作表中

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