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

【问题标题】：Find multiple strings, copy entire row and paste into another sheet查找多个字符串，复制整行并粘贴到另一个工作表中
【发布时间】：2022-02-26 07:25:42
【问题描述】：

我需要在工作表上找到某些名称，一旦找到所述名称就复制整行并将其粘贴到另一个工作表上。

我编写了找到其中一个名称的代码，然后复制该行并将其粘贴到另一张工作表中。

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

但我不得不硬编码 81 个名称，而不是数组中的 3 个项目。有没有办法从另一张纸上拉出一个数组的项目？

【问题讨论】：

几种方式。你在哪里定义了你的名字？它们是否存储在一张纸中？您不想在代码中硬编码 80 个名称。
@FunThomas 是的，它们存储在一个工作表中，比如工作表 12。它们都存储在从 A1 到 A83 的列中。我正在考虑用某种双循环或嵌套循环来做这件事，但我不确定如何实际编写代码来正确地做到这一点。
恭喜您在 StackOverflow 上发表第一篇文章！在您的情况下，提供输入表和预期结果的示例可能会很有用。
@Fredrik 谢谢！我设法找到了产生所需输出的代码，但我必须为此在一个数组中硬编码 80 个名称，然后使用循环（我已经编辑了显示代码的主要帖子）。您知道是否有任何方法可以将这些名称从工作表中的列表中提取到数组中，这样我就不必对它们进行硬编码？提前致谢！
名称列表的工作表名称和范围是什么？

标签： excel vba

【解决方案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

【讨论】：