跨多个工作簿查找重复的列值，并将列行数据提取到新工作表答案

【问题标题】：Find duplicate column values across multiple workbooks, and extract columns row data to new sheet跨多个工作簿查找重复的列值，并将列行数据提取到新工作表
【发布时间】：2021-10-19 04:05:13
【问题描述】：

我有多个 Excel 工作簿，其中一些有多个工作表。

我正在尝试使用每个工作簿的 A 列作为唯一值，将工作簿中的重复项导出到新工作簿中。所有工作簿都在同一个目录中。

我想出了以下方法，但它似乎不适用于具有多个工作表的工作簿，并且对于某些工作簿也不准确。

Sub CheckDuplicateAcrossWorkbook()
    Dim fName As String, fPath As String, wb As Workbook, sh As Worksheet, i As Long
    Set sh = ActiveSheet
    fPath = ThisWorkbook.Path & "\"
    fName = Dir(fPath & "*.xls*")
    
    Do
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            If sh.Range("B1") = "" Then
                sh.Range("A1") = "Source"
            End If
            wb.Sheets(1).UsedRange.Offset(1).Copy sh.Cells(Rows.Count, 2).End(xlUp)(2)
            With sh
               .Range(.Cells(Rows.Count, 1).End(xlUp)(2), .Cells(Rows.Count, 2).End(xlUp).Offset(, -1)) = fName
            End With
            wb.Close
        End If
        Set wb = Nothing
        fName = Dir
    Loop Until fName = ""
End Sub
```

The original code which removes the first five rows and 8th row with the header being row 7.

```vba
Sub CheckDuplicateAcrossWorkbookOriginal()
    Dim fName As String, fPath As String, wb As Workbook, sh As Worksheet, i As Long
    Set sh = ActiveSheet
    fPath = ThisWorkbook.Path & "\"
    fName = Dir(fPath & "*.xls*")
    Do
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            If sh.Range("B1") = "" Then
                wb.Sheets(1).Range("A7", Sheets(1).Cells(7, Columns.Count).End(xlToLeft)).Copy sh.Range("B1")
                sh.Range("A1") = "Source"
            End If
            wb.Sheets(1).UsedRange.Offset(8).Copy sh.Cells(Rows.Count, 2).End(xlUp)(2)
            With sh
                .Range(.Cells(Rows.Count, 1).End(xlUp)(2), .Cells(Rows.Count, 2).End(xlUp).Offset(, -1)) = fName
            End With
            wb.Close
        End If
        Set wb = Nothing
        fName = Dir
    Loop Until fName = ""    
    For i = sh.UsedRange.Rows.Count To 2 Step -1
        If Application.CountIf(sh.Range("B:B"), sh.Cells(i, 2).Value) = 1 Then Rows(i).Delete
    Next
End Sub

【问题讨论】：

标签： excel vba

【解决方案1】：

您需要遍历打开文件的每一页，而不是只使用第一页。试试这个...注意eSheet的添加。

Sub CheckDuplicateAcrossWorkbook()
Dim fName As String, fPath As String, wb As Workbook 
Dim sh As Worksheet, i As Long, eSheet As Worksheet
Set sh = ActiveSheet


fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xls*")
        Do
            If fName <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(fPath & fName)
                
                    For Each eSheet In wb.Worksheets
                        If sh.Range("B1") = "" Then
                            sh.Range("A1") = "Source"
                        End If
                        eSheet.UsedRange.Offset(8).Copy sh.Cells(Rows.Count, 2).End(xlUp)(2)
                    With sh
                        .Range(.Cells(Rows.Count, 1).End(xlUp)(2), .Cells(Rows.Count, 2).End(xlUp).Offset(, -1)) = fName
                    End With
                Next eSheet
                wb.Close
            End If
            Set wb = Nothing
            fName = Dir
        Loop Until fName = ""
End Sub

【讨论】：

嘿，感谢您的意见。我尝试了您的建议，但我在以下行出现运行时错误 1004 复制粘贴大小，尽管 eSheet.UsedRange.Offset(1).Copy sh.Cells(Rows.Count, 2).End(xlUp)(2)
你之前没有收到这个错误？
是的，没错
在复制之前添加这行代码，这样您就可以看到导致错误的工作表。 Debug.Print wb.Name & " " & eSheet.Name & " -- about to copy..."（确保在 VB 编辑器中显示即时窗口）。
如果您也有兴趣查看相关的问题，我已经发布了另一个问题，我已经重新编码。 [stackoverflow.com/questions/69629416/…@pgSystemTester

【解决方案2】：

我觉得这里有些人不会喜欢这个解决方案，因为它不是一个编码解决方案，但这对你 Kaiju 有用。

https://www.rondebruin.nl/win/addins/rdbmerge.htm

我不知道您要查找哪种“重复”，但是当所有内容合并在一起时，您可以做任何您需要做的事情。合并过程非常直观。只需按照登录页面中的步骤操作，您就应该得到您想要的。

【讨论】：