如果单元格包含数组中的名称，则在 Excel 中复制行答案

【问题标题】：Copy rows in Excel if cell contains name from an array如果单元格包含数组中的名称，则在 Excel 中复制行
【发布时间】：2016-06-09 00:10:10
【问题描述】：

我有一个 Excel 表，其中包含约 150 名员工的条目。每行包含姓名以及工作时间、工资、团队等。每行中的 B 列包含 Last,First 格式的员工姓名。表上大约一半的员工是兼职员工。我要做的是在VB中编写一个宏，如果B列中的名称与兼职员工的名称之一匹配，则复制整行，这样我的一位同事就可以简单地运行宏并粘贴所有每周将复制的用户行放入一个新工作表中。这是我目前拥有的。（我在数组中有所有员工的姓名，但我已经将它们删掉了）我真的不太了解最后 50% 的代码。这些东西是我在网上找到的并且一直在搞乱的东西。

`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean


nameArray = Array(NAMES CENSORED)

Set wsSource = ActiveSheet

NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add

For I = 1 To NoRows

    Set rngCells = wsSource.Range("C" & I & ":F" & I)
    Found = False
    For J = 0 To UBound(strArray)
        Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
    Next J

    If Found Then
        rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)

        DestNoRows = DestNoRows + 1
    End If
  Next I
End Sub`

【问题讨论】：

是否考虑过使用nameArray 作为Range.AutoFilter Method 中的条件？
抱歉，这到底是什么？我根本不懂VB，所以你必须忍受我：\
使用“数据”、“排序和筛选”、“自动筛选”记录自己并从 B 列中选择几个名称。关闭记录，您将看到名称数组所属的位置。
我认为我的 nameArray 会很好。我看到有人以这种方式实现了我正在尝试做的事情，我只是不知道如何遍历我的文件并进行比较。

标签： excel vba

【解决方案1】：

此代码应该适用于您要查找的内容。请务必注意，数组中的字符串名称必须与 B 列中的字符串名称相同（前导和尾随空格除外），因此如果名称写为“LastName，FirstName”，那么您的输入数据必须相同。这段代码可以调整为没有这个要求，但现在我把它保留了下来。如果您希望调整代码，请告诉我。

Option Explicit

Sub PartTimeEmployees()

Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")

'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2

'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
    If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
        For Counter = 1 To UBound(NameArray)
            'Performing string operations on the text will be faster than the find method
            'It is also essential that the names are entered identically in your array
            If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
                CurrentSheet.Rows(Count).Copy
                NewSheet.Select
                NewSheet.Cells(NextRow, 1).Select
                ActiveSheet.Paste
                CurrentSheet.Select
                NextRow = NextRow + 1
                Exit For
            End If
        Next Counter
    End If
Next Count

End Sub

【讨论】：

【解决方案2】：

如果您使用Range.AutoFilter Method 并将数组作为条件，则无需遍历数组。

查看每行操作代码的注释。

Option Explicit

Sub partTimers()
    Dim nameArray  As Variant

    'construct an array of the part-time employees' names
    nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
                      "Sfgd, Pxduj", "Lsds, Qwrml", _
                      "Eqrd, Oqtts")

    With Worksheets("Sheet1")   'you should know what worksheet the names are on
        'turn off AutoFilter is there is one already in operation
        If .AutoFilterMode Then .AutoFilterMode = False
        'use the 'island' of cells radiating out from A1
        With .Cells(1, 1).CurrentRegion
            'apply AutoFilter using array of names as criteria
            .AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
            'check if there is anything to copy
            If Application.Subtotal(103, .Columns(2)) > 1 Then
                'copy the filtered range
                .Cells.Copy
                'create a new worksheet
                With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
                    'paste the filtered range, column widths and cell formats
                    .Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
                    .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
                    .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
                End With
            End If
        End With
        'turn off the AutoFilter
        If .AutoFilterMode Then .AutoFilterMode = False
        'turn off active copy range
        Application.CutCopyMode = False
    End With

End Sub

【讨论】：