Использование VBA для объединения данных из нескольких рабочих книг

Question

Прошу прощения, если этот вопрос уже задавался. Я искал и нашел только один запрос, который в некоторой степени связан с моей ситуацией: как объединить сотни файлов электронных таблиц Excel? ,

Я изменил код, предоставленный Крисом Кентом в связанном посте, чтобы попытаться решить мою проблему.

Здесь я пытаюсь получить определенный диапазон данных из нескольких рабочих книг и вставить их в одну с помощью VBA в Excel 2010. В конце концов я добавлю сводную страницу с суммой каждого набора данных. На данный момент моей главной проблемой является получение информации из нескольких рабочих книг для успешного копирования.

Каждый диапазон одинаков в каждой книге.

Мне не нужно тянуть заголовки.

Мне нужен только 1 лист данных.

В коде, которым я манипулировал, чтобы лучше соответствовать моим требованиям ниже, я сталкиваюсь со следующими проблемами:

1. Данные из первых двух файлов (даты 11-23-15 и 11-24-15) не переносятся. У меня есть ощущение, что это связано с неотредактированной частью кода, которую я еще не коснулся относительно удаления столбцов / строк с нулями, показанными ниже.

   Private Function GetTrueEnd(ws As Worksheet) As Range
       Dim lastRow As Long
       Dim lastCol As Long
       Dim r As Long
       Dim c As Long
   
       On Error Resume Next
       lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
       lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
       On Error GoTo 0
   
       If lastCol <> 0 And lastRow <> 0 Then
   
           ' look back through the last rows of the table, looking for a non-zero value
           For r = lastRow To 1 Step -1
               For c = 1 To lastCol
                   If ws.Cells(r, c).Text <> "" Then
                       If ws.Cells(r, c).Text <> 0 Then
                           Set GetTrueEnd = ws.Cells(r, lastCol)
                           Exit Function
                       End If
                   End If
               Next c
           Next r
       End If
   
       Set GetTrueEnd = ws.Cells(1, 1)
   End Function
   

2. Дата из первого файла (как имя файла) указана в столбце B, а дата из второго файла - в столбце C, когда они должны быть указаны в столбце E. Это может быть частью того же предположения, которое я имею на # 1.

3. Данные с 11-25-15 и 11-26-15 имеют #REF! ошибка. Я надеюсь, что если я пойму, как извлекать только значения, а не формулы, это исправит эту ошибку. Тем не менее, это не происходит в другие даты, поэтому я не уверен, является ли это основной проблемой. Единственное место, которое я знаю, чтобы попытаться использовать.Значение 'или'.Pastespecial 'коды в следующем, но я еще не получил его работать:

   If mainLastEnd(i).Row > 1 Then
   ' There is data in the sheet
   
   ' Copy new data (skip headings)
           externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)
   

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

Вот весь код:

Option Explicit
Const NUMBER_OF_SHEETS = 1

Public Sub GiantMerge()
    Dim externWorkbookFilepath As Variant
    Dim externWorkbook As Workbook
    Dim i As Long
    Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range
    Dim mainCurEnd As Range

    Application.ScreenUpdating = False

    ' Initialise

    ' Correct number of sheets
    Application.DisplayAlerts = False
    If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
        ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
    ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
        For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
            ThisWorkbook.Sheets(i).Delete
        Next i
    End If
    Application.DisplayAlerts = True

    For i = 1 To NUMBER_OF_SHEETS
        Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i))
    Next i


    ' Load the data
    For Each externWorkbookFilepath In GetWorkbooks()
        Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)

        For i = 1 To NUMBER_OF_SHEETS

            If mainLastEnd(i).Row > 1 Then
                ' There is data in the sheet

                ' Copy new data (skip headings)
                externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)

                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i))
            Else
                ' No data in sheet yet (prob very first run)

                ' Get correct sheet name from first file we check
                ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name


                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1)


            End If

            ' Add file name into extra column
            ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name

            Set mainLastEnd(i) = mainCurEnd
        Next i

        externWorkbook.Close
    Next externWorkbookFilepath

    Application.ScreenUpdating = True
    End Sub

    ' Returns a collection of file paths, or an empty collection if the user selects cancel
    Private Function GetWorkbooks() As Collection
    Dim fileNames As Variant
    Dim xlFile As Variant

    Set GetWorkbooks = New Collection

    fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
                                               FileFilter:="Excel Files, *.xlsm;*.xlsx", _
                                               MultiSelect:=True)
    If TypeName(fileNames) = "Variant()" Then
        For Each xlFile In fileNames
            GetWorkbooks.Add xlFile
        Next xlFile
    End If
    End Function

    ' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
    Private Function GetTrueEnd(ws As Worksheet) As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long

    On Error Resume Next
    lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
    lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
    On Error GoTo 0

    If lastCol <> 0 And lastRow <> 0 Then

        ' look back through the last rows of the table, looking for a non-zero value
        For r = lastRow To 1 Step -1
            For c = 1 To lastCol
                If ws.Cells(r, c).Text <> "" Then
                    If ws.Cells(r, c).Text <> 0 Then
                        Set GetTrueEnd = ws.Cells(r, lastCol)
                        Exit Function
                    End If
                End If
            Next c
        Next r
    End If

    Set GetTrueEnd = ws.Cells(1, 1)
    End Function

Answer 1

Я нашел другой код, который удовлетворил мои потребности. У меня будет несколько вещей для настройки, например, добавление функции сортировки.

Этот код занял все файлы, которые я хочу открыть, скопировал выбор и вставил на новый лист, объединив все данные в один из нескольких рабочих книг.

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

Вот ссылка, по которой я получил этот код и затем изменил его в соответствии со своими потребностями:

Рон де Брюин: Примеры рабочих книг: объединение данных из всех рабочих книг в папке

Код выглядит следующим образом:

Option Explicit


Sub Basic_Example_2()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant




FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                    MultiSelect:=True)
If IsArray(FName) Then

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1


    'Loop through all files in the array(myFiles)
    For Fnum = LBound(FName) To UBound(FName)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(FName(Fnum))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            On Error Resume Next
            With mybook.Worksheets(1)
                Set sourceRange = .Range("A19:E23")
            End With

            If Err.Number > 0 Then
                Err.Clear
                Set sourceRange = Nothing
            Else
                'if SourceRange use all columns then skip this file
                If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                    Set sourceRange = Nothing
                End If
            End If
            On Error GoTo 0

            If Not sourceRange Is Nothing Then

                SourceRcount = sourceRange.Rows.Count

                If rnum + SourceRcount >= BaseWks.Rows.Count Then
                    MsgBox "Sorry there are not enough rows in the sheet"
                    BaseWks.Columns.AutoFit
                    mybook.Close savechanges:=False
                    GoTo ExitTheSub
                Else

                    'Copy the file name in column A
                    With sourceRange
                        BaseWks.Cells(rnum, "A"). _
                                Resize(.Rows.Count).Value = FName(Fnum)
                    End With

                    'Set the destrange
                    Set destrange = BaseWks.Range("B" & rnum)

                    'we copy the values from the sourceRange to the destrange
                    With sourceRange
                        Set destrange = destrange. _
                                        Resize(.Rows.Count, .Columns.Count)
                    End With
                    destrange.Value = sourceRange.Value

                    rnum = rnum + SourceRcount
                End If
            End If
            mybook.Close savechanges:=False
        End If

    Next Fnum
    BaseWks.Columns.AutoFit
End If

ExitTheSub:

End Sub