Объединение рабочих тетрадей с проверкой дубликатов

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

Исходя из того, что вы хотите, чтобы ваше сравнение было, я бы посоветовал вам использовать этот код.

Он использует Словарь для создания списка счетов-фактур #, которые уже находятся в объединенномфайл.Преимущество использования словаря состоит в том, что вы можете напрямую проверить, существует ли запись для вашего значения, не заботясь о типе ее содержимого.

Я не проверял ее, но не ожидаю особых проблем.Тем не менее, я все еще задаюсь вопросом, почему вам нужно перебирать листы вашего файла счета.Я предположил, что у вас есть один счет на файл, и номер счета всегда находится на первом листе в диапазоне 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

Answer 2

Если я правильно понимаю, вы хотите объединить рабочие листы из числа других рабочих книг X (wbkSrcBook) в основную рабочую книгу (wbkCurBook), но игнорируете дубликаты рабочих листов?

Моим первым вопросом было бы выяснить, что является уникальным для каждого листа, и или сгенерировать какое-либо уникальное значение / псевдо-хэш / сцепленное значение, которое можно использовать для их дифференциации - проще всего будет, если имя рабочего листа уникально, но еслине столбец с номером счета или даже объединение различных строк на каждом листе.

Как только вы поймете это, тогда я представлю, что это будет достаточно просто: создание списка / массива для отслеживания ваших уникальных идентификаторов / имен листов, а затем проверка каждого нового исходного имени / идентификатора листа рабочей книги.против массива - Добавление в основную книгу, если 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

Я тестировал большую часть этого кода в сегментах, ноЯ не пробовал все это вместе - поэтому может потребоваться некоторая настройка, прежде чем вы добавите его обратно в модуль!Я использовал имена листов в качестве простого дифференциатора, но если вам нужно использовать другое, логика не должна сильно меняться.