Vba VBLOOKUP和MATCH可识别列中的问题

为了使事情尽可能简单，让我们假设我有3张纸。表1包含姓名和团队。表2只需包含与特定团队相关的名称。但是，名称是手动输入的。如何检查表2以确保其上的所有名称都属于特定的团队，并向表3输出歧义？需要注意的是，每个不断变化的名称列表的侧面都有额外的列和行，而这些差异在每个表中并不一致

表1

Seger, Bob          Team A
Hendrix, Jimi       Team B
Osbourne, Ozzy      Team C
Shepherd, Kenny     Team B
Rose, Axl           Team A
Keenan, Maynard     Team C

第2页（仅适用于B组）

第3页（不准确）

---

在sheet3中未使用列的顶部尝试此操作，并填写以备后续匹配

=INDEX(Sheet2!A:A, AGGREGATE(15, 6, ROW($2:$99)/NOT(COUNTIFS(Sheet1!A$2:A$99, Sheet2!A$2:A$99, Sheet1!B$2:B$99, "team b")), ROW(1:1)))

---

你可以使用字典

Option Explicit
Public Sub VerifyNamesInSheet()

    Application.ScreenUpdating = False

    Const SHEET_TO_CHECK As String = "Sheet2"
    Const TEAM_TO_CHECK As String = "Team B"
    Dim teamNamesDict As Object, misplacedDict As Object, valuesToProcess()
    Set teamNamesDict = CreateObject("Scripting.Dictionary")
    Set misplacedDict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        valuesToProcess = .Range("A1:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With

    Dim i As Long

    For i = LBound(valuesToProcess, 1) To UBound(valuesToProcess, 1)
        If valuesToProcess(i, 2) = TEAM_TO_CHECK Then
            If Not teamNamesDict.Exists(valuesToProcess(i, 1)) Then teamNamesDict.Add valuesToProcess(i, 1), valuesToProcess(i, 1)
        End If
    Next i

    With ThisWorkbook.Worksheets(SHEET_TO_CHECK)
        valuesToProcess = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value

        For i = LBound(valuesToProcess, 1) To UBound(valuesToProcess, 1)
            If Not teamNamesDict.Exists(valuesToProcess(i, 1)) And Not misplacedDict.Exists(valuesToProcess(i, 1)) Then misplacedDict.Add valuesToProcess(i, 1), valuesToProcess(i, 1)
        Next i

    End With

    With ThisWorkbook.Worksheets("Sheet3")
        .UsedRange.ClearContents
        .Range("A1").Resize(misplacedDict.Count, 1) = Application.WorksheetFunction.Transpose(misplacedDict.Keys)
    End With

    Application.ScreenUpdating = True
End Sub

---

我很感谢您的意见，但我正试图完全用VBA来完成这项工作。我必须证明我的电子表格是白痴，VBA是唯一允许用户输入信息而不破坏公式的方法。此外，名称可能会有任意数量的条目，而这些工作表将没有定义的表。“VBA是唯一允许用户输入信息而不破坏公式的方法。”这不是真的！您可以轻松地保护工作表及其公式，这样其他用户就不会意外地更改它们，但仍然可以输入数据。@Pᴇʜ如果我保护工作表，则用户无法在插入的表中输入信息。问题是，我的工作表中始终包含公式，而这些公式不会自动转移到表外的新行。我下班回家后会对此进行测试，看看它是否按要求处理。我不知道为什么这对我来说如此困难，但我试了好几次，都失败了。我将在检查后更新。

=INDEX(Sheet2!A:A, AGGREGATE(15, 6, ROW($2:$99)/NOT(COUNTIFS(Sheet1!A$2:A$99, Sheet2!A$2:A$99, Sheet1!B$2:B$99, "team b")), ROW(1:1)))

Option Explicit
Public Sub VerifyNamesInSheet()

    Application.ScreenUpdating = False

    Const SHEET_TO_CHECK As String = "Sheet2"
    Const TEAM_TO_CHECK As String = "Team B"
    Dim teamNamesDict As Object, misplacedDict As Object, valuesToProcess()
    Set teamNamesDict = CreateObject("Scripting.Dictionary")
    Set misplacedDict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        valuesToProcess = .Range("A1:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With

    Dim i As Long

    For i = LBound(valuesToProcess, 1) To UBound(valuesToProcess, 1)
        If valuesToProcess(i, 2) = TEAM_TO_CHECK Then
            If Not teamNamesDict.Exists(valuesToProcess(i, 1)) Then teamNamesDict.Add valuesToProcess(i, 1), valuesToProcess(i, 1)
        End If
    Next i

    With ThisWorkbook.Worksheets(SHEET_TO_CHECK)
        valuesToProcess = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value

        For i = LBound(valuesToProcess, 1) To UBound(valuesToProcess, 1)
            If Not teamNamesDict.Exists(valuesToProcess(i, 1)) And Not misplacedDict.Exists(valuesToProcess(i, 1)) Then misplacedDict.Add valuesToProcess(i, 1), valuesToProcess(i, 1)
        Next i

    End With

    With ThisWorkbook.Worksheets("Sheet3")
        .UsedRange.ClearContents
        .Range("A1").Resize(misplacedDict.Count, 1) = Application.WorksheetFunction.Transpose(misplacedDict.Keys)
    End With

    Application.ScreenUpdating = True
End Sub