Question

我正在尝试添加功能以识别重复的工作簿，以使它们不会被导入。我在编写If stmt时遇到麻烦，如果将标签/工作表已导入到主文件中，它将捕获。

    Sub MergeExcelFiles()

    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim WS As Worksheet
    Dim Z As Integer
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

If (vbBoolean <> VarType(fnameList)) Then

    If (UBound(fnameList) > 0) Then
        countFiles = 0
        countSheets = 0

        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual

        Set wbkCurBook = ActiveWorkbook

        For Each fnameCurFile In fnameList
            countFiles = countFiles + 1

            Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

            'If stmt'***

            For Each wksCurSheet In wbkSrcBook.Sheets
                countSheets = countSheets + 1
                wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)

            Next

            wbkSrcBook.Close SaveChanges:=False

        Next

        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic

        MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
    End If

Else
    MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

Answer 1

如果我的理解正确，您希望将工作表从X数量的其他工作簿（wbkSrcBook）合并到您的主工作簿（wbkCurBook）中，而忽略任何重复的工作表？

然后，我的第一个问题是弄清楚每张纸的独特之处，或者以其他方式生成可用于区分它们的唯一/伪哈希/连接值-最简单的是工作表名称（如果很明显是唯一的），但如果不是，则为一列，其中包含帐号，甚至每个工作表中各种字符串的组合。

一旦弄清楚了，那么我想这将是相当简单的-创建一个列表/数组以跟踪您的唯一ID /工作表名称，然后对照该数组检查每个新的源工作簿工作表名称/ ID -如果为False，则添加到主工作簿；如果为True，则不执行任何操作。

用于检查数组中是否存在某些东西（要与SheetList数组一起使用）的功能

Private Function CheckArray(value, arr) As Boolean

Dim x As Variant

On Error GoTo CAExit:

For Each x In arr:
    If x = value Then
        CheckArray = True
        On Error GoTo 0
        Exit Function
    End If
Next

CAExit:
On Error GoTo 0
CheckArray = False

End Function

将初始主要书籍工作表名称（wbkCurBook）添加到数组中

Dim SheetList As Variant

For Each wksCurSheet In wbkCurBook.Sheets
    If IsEmpty(SheetList) Then
        SheetList = Array(wksCurSheet.Name)
    Else
        ReDim Preserve SheetList(UBound(SheetList) + 1)
        SheetList(UBound(SheetList)) = wksCurSheet.Name
    End If
Next

打开源书籍以从（wbkSrcBook）复制数据后，将这些工作表名称/值与数组进行比较。如果在数组中找到新值，则丢弃-如果找不到，则将工作表复制到主书（wbkCurBook），然后将新值添加到数组中

For Each wksCurSheet In wbkSrcBook.Sheets
    If CheckArray("LookUp", SheetList) = False Then
        countSheets = countSheets + 1
        wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
        If IsEmpty(SheetList) Then
            SheetList = Array(wksCurSheet.Name)
        Else
            ReDim Preserve SheetList(UBound(SheetList) + 1)
            SheetList(UBound(SheetList)) = wksCurSheet.Name
        End If
    End If 
Next

我在段中测试了大部分代码，但是还没有一起尝试过-因此在将其放回模块之前可能需要进行一些调整！我使用工作表名称作为一个轻松的区分符，但是如果您必须使用其他名称，那么逻辑应该不会有太大变化。

Answer 2

根据您希望进行的比较，建议您使用此代码。

它使用Dictionary创建已合并文件中的发票编号列表。使用字典的好处是，您可以直接检查是否存在用于您的值的条目，而不必担心其内容的类型。

我还没有测试过，但是期望不会有太多问题。但是，我仍然质疑为什么您需要循环浏览发票文件的表格。我以为您每个文件只有一张发票，并且发票号始终在A1范围的第一张纸上。和往常一样，不要犹豫，使代码适应您的需求。

Option Explicit

Sub MergeExcelFiles()

    Dim fnameList As Variant
    Dim fnameCurFile As Variant
    Dim countFiles As Long
    Dim countSheets As Long
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook As Workbook
    Dim wbkSrcBook As Workbook

    Dim Invoices As Object
    Set Invoices = CreateObject("Scripting.Dictionary")


    Dim Invoice As String

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook


            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                'Open the file in Readonly and get the Invoice # store in Cell A1
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile, ReadOnly:=True)
                Invoice = wbkSrcBook.Worksheets(1).Range("A1").Value


                If Invoices.Exists(Invoice) Then
                    'This Invoice is already in the Workbook
                    'We can skip it

                Else
                    'This invoice is not in the Merged Workbook
                    Dim i As Long
                    For i = 1 To wbkSrcBook.Sheets.Count
                        countSheets = countSheets + 1
                        wbkSrcBook.Sheets(i).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                    Next
                    Invoices.Add Invoice, vbNullString

                End If

                'We can close the workbook
                wbkSrcBook.Close SaveChanges:=False



            Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If

    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

合并带有重复验证的工作簿

2 个答案: