我有多個 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
uj5u.com熱心網友回復：
您需要遍歷打開檔案的每張紙，而不僅僅是使用第一張。試試這個...注意添加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
uj5u.com熱心網友回復：
我覺得這里有些人不會喜歡這個解決方案，因為它不是一個編碼解決方案，但這對你 Kaiju 有用。
https://www.rondebruin.nl/win/addins/rdbmerge.htm
我不知道你想找到什么樣的“重復”，但是當所有東西都合并在一起時，你可以做任何你需要做的事情。合并程序非常直觀。只需按照登錄頁面中的步驟操作，您就會得到您想要的。
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/324381.html