通过VBA宏在5个Excel工作表中查找重复客户ID并汇总至第6表

核心思路 #

利用Scripting.Dictionary实现高效的ID存储与查找（O(1)级查询效率），分三步完成需求：

• 遍历所有目标工作表，收集每个客户ID对应的来源工作表列表
• 标记跨表重复的ID单元格
• 将重复ID及来源信息汇总到指定工作表

完整VBA代码 #

Sub FindCrossSheetDuplicates()
    Dim idDict As Object
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim key As Variant
    Dim rowNum As Long
    
    ' 初始化字典：键=客户ID，值=来源工作表名称列表
    Set idDict = CreateObject("Scripting.Dictionary")
    idDict.CompareMode = vbTextCompare ' 不区分大小写（需严格区分则删除此行）
    
    ' 初始化汇总工作表（自动创建或复用现有表）
    On Error Resume Next
    Set targetWs = ThisWorkbook.Worksheets("重复汇总")
    On Error GoTo 0
    If targetWs Is Nothing Then
        Set targetWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        targetWs.Name = "重复汇总"
    End If
    targetWs.Cells.Clear
    targetWs.Range("A1:B1").Value = Array("客户ID", "来源工作表")
    targetWs.Range("A1:B1").Font.Bold = True
    rowNum = 2
    
    ' 第一步：遍历所有Cam工作表，收集ID及来源
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "Cam *" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 假设ID在A列
            For Each cell In ws.Range("A2:A" & lastRow) ' 跳过表头行
                If cell.Value <> "" Then
                    If idDict.Exists(cell.Value) Then
                        idDict(cell.Value) = idDict(cell.Value) & ", " & ws.Name
                    Else
                        idDict(cell.Value) = ws.Name
                    End If
                End If
            Next cell
        End If
    Next ws
    
    ' 第二步：标记重复ID的单元格（浅红色背景）
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "Cam *" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            For Each cell In ws.Range("A2:A" & lastRow)
                If cell.Value <> "" Then
                    If UBound(Split(idDict(cell.Value), ", ")) > 0 Then
                        cell.Interior.Color = RGB(255, 204, 204)
                    End If
                End If
            Next cell
        End If
    Next ws
    
    ' 第三步：将重复ID写入汇总表
    For Each key In idDict.Keys
        If UBound(Split(idDict(key), ", ")) > 0 Then
            targetWs.Cells(rowNum, "A").Value = key
            targetWs.Cells(rowNum, "B").Value = idDict(key)
            rowNum = rowNum + 1
        End If
    Next key
    
    ' 自动调整汇总表列宽
    targetWs.Columns("A:B").AutoFit
    
    MsgBox "重复ID检测与汇总完成！", vbInformation
End Sub

使用说明 #

1. 列位置调整：若客户ID不在A列，将代码中所有"A"替换为对应列字母（如"B"）。
2. 颜色自定义：修改RGB(255,204,204)可调整重复单元格的标记颜色。
3. 大小写敏感：删除idDict.CompareMode = vbTextCompare即可启用严格大小写匹配。
4. 运行方式：按Alt+F11打开VBA编辑器，将代码粘贴到模块中，直接运行宏。

内容的提问来源于stack exchange，提问作者Velimir Novakov