Excel VBA如何从其他工作表读取名单批量匹配并复制对应行到新表

完全可以直接从工作表读取姓名填充数组，不需要手动硬编码80个姓名，以下是适配你原有逻辑的完整代码：

Sub 多姓名匹配复制()
    Dim StatusCol As Range
    Dim Status As Range
    Dim PasteCell As Range
    Dim 姓名表 As Worksheet
    Dim 姓名数组 As Variant
    Dim i As Long
    
    ' 配置项：修改为你存放目标姓名的工作表
    Set 姓名表 = ThisWorkbook.Worksheets("你的姓名工作表名") ' 也可以写Sheet代号，比如Sheet12
    ' 读取姓名表A列从A2开始的所有姓名到数组（A1为表头的情况，无表头就改成A1）
    姓名数组 = 姓名表.Range("A2:A" & 姓名表.Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    ' 原有数据源范围保留你的配置
    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
        
        ' 匹配姓名数组中的值，匹配成功则复制对应行
        For i = 1 To UBound(姓名数组)
            If Status.Value = 姓名数组(i, 1) Then
                ' 保留你原有的偏移复制规则，如需复制整行可改成Status.EntireRow.Copy PasteCell
                Status.Offset(0, -4).Resize(1, 5).Copy PasteCell
                Exit For ' 匹配到就跳出循环，避免重复判断
            End If
        Next i
    Next Status
    
    ' 清空剪贴板
    Application.CutCopyMode = False
End Sub

注意事项 #

• 请先将代码里的你的姓名工作表名替换为你实际存放80个姓名的工作表名称
• 如果你的姓名不是存放在姓名表的A列，修改Range("A2:A")的列号即可
• 如果你原有的偏移规则Offset(0, -4)运行时报错，说明你匹配的单元格位置往左偏移4列超出了工作表边界，调整偏移值即可
• 如果你希望代码运行效率更高，可以把内层的姓名遍历循环替换为Match函数判断，写法更简洁速度也更快：

' 替换内层For i循环的代码
If Not IsError(Application.Match(Status.Value, 姓名数组, 0)) Then
    Status.Offset(0, -4).Resize(1, 5).Copy PasteCell
End If

内容的提问来源于stack exchange，提问作者Freddy Frost