VBA检查座次表的sheet2人员是否在sheet1中

使用sheet2的人员，在sheet1中排座次，排好后检查有无漏人？

Sub 验证人名是否存在()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, cell As Range
    Dim found As Range
    Dim missingList As String
    Dim missingCount As Long
    
    ' 设置工作表
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet1的查找范围：D3到Q24
    Set rng1 = ws1.Range("D3:Q24")
    
    ' 关闭屏幕更新，提高运行速度
    Application.ScreenUpdating = False
    
    ' 初始化
    missingCount = 0
    missingList = ""
    
    ' 遍历Sheet2的D2到D76
    For Each cell In ws2.Range("D2:D76")
        If cell.Value <> "" Then  ' 跳过空单元格
            ' 在Sheet1的D3:Q24范围内查找
            Set found = rng1.Find(What:=cell.Value, _
                                  LookIn:=xlValues, _
                                  LookAt:=xlWhole, _
                                  MatchCase:=False)
            
            If found Is Nothing Then
                ' 未找到，标记为红色并记录
                cell.Interior.Color = RGB(255, 0, 0)  ' 红色背景
                missingCount = missingCount + 1
                missingList = missingList & "第" & cell.Row & "行: " & cell.Value & vbCrLf
            Else
                ' 找到了，标记为绿色
                cell.Interior.Color = RGB(0, 255, 0)  ' 绿色背景
            End If
        End If
    Next cell
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    ' 显示结果
    If missingCount = 0 Then
        MsgBox "验证完成！Sheet2的D2:D76所有人名都在Sheet1的D3:Q24中存在。", vbInformation, "验证结果"
    Else
        MsgBox "验证完成！共有 " & missingCount & " 个人名在Sheet1的D3:Q24中不存在：" & vbCrLf & vbCrLf & missingList, vbExclamation, "验证结果"
    End If
End Sub

另外检查座次结果有无重复人名（同名除名），范围：指定8行（3,6,9,12,15,18,21,24）的D-Q列中有无重复人名

Sub 检查重复人名()
    Dim ws As Worksheet
    Dim rng As Range, cell As Range
    Dim dict As Object
    Dim nameList As String
    Dim duplicateCount As Long
    Dim cellAddress As String
    Dim targetRows As Variant
    Dim i As Long
    
    ' 设置工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 定义要检查的行
    targetRows = Array(3, 6, 9, 12, 15, 18, 21, 24)
    
    ' 创建字典对象
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 关闭屏幕更新
    Application.ScreenUpdating = False
    
    ' 先清除之前D3:Q24区域的颜色标记
    ws.Range("D3:Q24").Interior.ColorIndex = xlNone
    
    ' 初始化
    duplicateCount = 0
    nameList = ""
    
    ' 遍历指定行的D到Q列
    For i = LBound(targetRows) To UBound(targetRows)
        Set rng = ws.Range("D" & targetRows(i) & ":Q" & targetRows(i))
        For Each cell In rng
            If cell.Value <> "" Then  ' 跳过空单元格
                If Not dict.exists(cell.Value) Then
                    ' 第一次出现，记录位置
                    dict.Add cell.Value, cell.Address(False, False)
                Else
                    ' 重复出现，标记为黄色
                    cell.Interior.Color = RGB(255, 255, 0)  ' 黄色背景
                    
                    ' 同时标记第一次出现的位置
                    cellAddress = dict(cell.Value)
                    ws.Range(cellAddress).Interior.Color = RGB(255, 255, 0)
                    
                    ' 记录重复信息（只记录一次）
                    If InStr(1, nameList, cell.Value & "|") = 0 Then
                        duplicateCount = duplicateCount + 1
                        nameList = nameList & cell.Value & " (首次出现: " & cellAddress & ")" & vbCrLf
                    End If
                End If
            End If
        Next cell
    Next i
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    ' 显示结果
    If duplicateCount = 0 Then
        MsgBox "检查完成！指定8行（3,6,9,12,15,18,21,24）的D-Q列中没有重复的人名。", vbInformation, "重复检查结果"
    Else
        MsgBox "检查完成！共发现 " & duplicateCount & " 个重复的人名：" & vbCrLf & vbCrLf & nameList, vbExclamation, "重复检查结果"
    End If
    
    ' 释放对象
    Set dict = Nothing
End Sub