跨多Excel工作簿查找A列重复值并提取行数据的VBA优化问询

解决的原有缺陷 #

• 支持遍历单个工作簿下所有可见工作表，不再仅处理第一个工作表
• 支持自定义表头行，不会默认删除前置行
• 按A列取值作为唯一标识判断重复，仅保留出现2次及以上的重复行数据
• 自动记录数据来源：对应工作簿名称+工作表名称
• 采用字典计数，处理大数据量时效率远高于逐行CountIf判断

Sub ExportDuplicateRows()
    ' 可自定义参数：修改此处为你实际的表头所在行号
    Const HEADER_ROW As Long = 1
    
    Dim fPath As String, fName As String
    Dim wb As Workbook, ws As Worksheet, resultWs As Worksheet
    Dim dict As Object
    Dim lastRow As Long, lastCol As Long, i As Long, resultLastRow As Long
    Dim uniqueKey As String
    
    ' 初始化字典用于统计A列值出现次数
    Set dict = CreateObject("Scripting.Dictionary")
    Set resultWs = ThisWorkbook.ActiveSheet
    resultWs.Cells.Clear ' 清空当前工作表原有内容
    fPath = ThisWorkbook.Path & "\"
    fName = Dir(fPath & "*.xls*")
    
    ' 第一遍遍历：统计所有A列值的出现次数
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(Filename:=fPath & fName, ReadOnly:=True)
            For Each ws In wb.Worksheets
                ' 跳过隐藏工作表
                If ws.Visible = xlSheetVisible Then
                    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                    ' 跳过行数不足的工作表
                    If lastRow >= HEADER_ROW + 1 Then
                        For i = HEADER_ROW + 1 To lastRow
                            uniqueKey = CStr(ws.Cells(i, "A").Value)
                            If uniqueKey <> "" Then
                                dict(uniqueKey) = dict(uniqueKey) + 1
                            End If
                        Next i
                    End If
                End If
            Next ws
            wb.Close SaveChanges:=False
        End If
        fName = Dir
    Loop
    
    ' 写入结果表表头
    resultWs.Range("A1") = "来源工作簿"
    resultWs.Range("B1") = "来源工作表"
    fName = Dir(fPath & "*.xls*")
    Dim headerWritten As Boolean
    
    ' 第二遍遍历：导出所有重复的行数据
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(Filename:=fPath & fName, ReadOnly:=True)
            For Each ws In wb.Worksheets
                If ws.Visible = xlSheetVisible Then
                    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                    lastCol = ws.Cells(HEADER_ROW, ws.Columns.Count).End(xlToLeft).Column
                    If lastRow >= HEADER_ROW + 1 Then
                        ' 第一次读取表头时写入结果表
                        If Not headerWritten Then
                            ws.Range(ws.Cells(HEADER_ROW, 1), ws.Cells(HEADER_ROW, lastCol)).Copy _
                            resultWs.Range("C1")
                            headerWritten = True
                        End If
                        ' 遍历行，导出重复项
                        For i = HEADER_ROW + 1 To lastRow
                            uniqueKey = CStr(ws.Cells(i, "A").Value)
                            If uniqueKey <> "" And dict(uniqueKey) >= 2 Then
                                resultLastRow = resultWs.Cells(resultWs.Rows.Count, "C").End(xlUp).Row + 1
                                ' 写入来源信息
                                resultWs.Cells(resultLastRow, "A") = fName
                                resultWs.Cells(resultLastRow, "B") = ws.Name
                                ' 写入整行数据
                                ws.Range(ws.Cells(i, 1), ws.Cells(i, lastCol)).Copy _
                                resultWs.Cells(resultLastRow, "C")
                            End If
                        Next i
                    End If
                End If
            Next ws
            wb.Close SaveChanges:=False
        End If
        fName = Dir
    Loop
    
    ' 自动调整列宽
    resultWs.UsedRange.EntireColumn.AutoFit
    MsgBox "重复数据导出完成！", vbInformation
    
    Set dict = Nothing
    Set ws = Nothing
    Set wb = Nothing
    Set resultWs = Nothing
End Sub

使用说明 #

1. 新建一个空白Excel工作簿，按Alt+F11打开VBA编辑器，右键点击当前工作簿名称选择「插入」-「模块」，将上述代码粘贴到模块中
2. 将该空白工作簿保存为「Excel 启用宏的工作簿(*.xlsm)」格式，和所有需要处理的Excel文件放到同一个文件夹下
3. 回到Excel界面，按Alt+F8选择ExportDuplicateRows宏运行即可，运行结束后当前工作表会自动生成所有重复行数据

自定义调整说明 #

如果你的数据表头不是第一行，只需要修改代码开头的Const HEADER_ROW As Long = 1，将等号后的数值改为你实际的表头行号即可。

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