Using VBA to merge data from multiple workbooks

Question

I apologize if this question has already been asked. I've searched and found only one query that's somewhat related to my situation: How can I merge hundreds of Excel spreadsheet files?.

I’ve modified the code provided by Chris Kent in the linked post to attempt to solve my issue.

What I'm trying to accomplish here is to pull a specific range of data from multiple workbooks and paste them to one using VBA in Excel 2010. Eventually I’ll add a summary page of sum of each set of data. For now, my main issue is getting the information from multiple workbooks to copy over successfully.

Each range is the same on each workbook .

I do not need headers to be pulled.

I only need 1 sheet worth of data.

In the code I’ve manipulated to better suit my needs below, I am running into the following issues:

1. The data from the first two files (dates 11-23-15 and 11-24-15) is not pulling over. I have a feeling it has to do with the un-edited part of code I have yet to touch regarding removing columns/rows with 0’s shown below.

   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. The date from the first file (as File Name) is listed in the Column B and the date from the second file is listed in Column C when they should be listed in Column E. This may be part of the same assumption I have on #1.

3. Data from 11-25-15 and 11-26-15 have a #REF! error. I’m hoping if I figure out how to pull values only and not formulas, it will fix this error. However, it doesn’t happen on any other dates so I’m unsure if this is the underlying issue. The only place I know to try to use the '.Value' or '.Pastespecial' codes are in the following, but I haven't gotten it to work yet:

   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)
   

If anyone could help me resolve the issues above, I would greatly appreciate it.

Here is all of the code:

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

I've found a different code that has satisfied my needs. I will have a few things to adjust, like adding a sort function.

This code has taken all files I wish to open, copied the selection, and pasted to a new sheet, combining all data to one from multiple workbooks.

It does open the data in a new sheet outside of the one I'm running the code through, but that works perfectly fine for me. I can choose to save it or just print it for reference.

Here is the link from which I obtained this code then modified to suit my needs:

Ron de Bruin: Workbookexamples:Merge data from all workbooks in a folder

Code is as follows:

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