I had an opportunity where I had several workbooks (5 to be exact) that are updated on a regular basis, daily in some cases. Each workbook has similar information but in different locations. For my usage I desired to combine the applicable columns into a single set of columns in one Excel file. A merged document will allow me to look in one location rather than five, and find all the results.

I searched and searched and wasn’t able to find anyone else who had solved my particular problem. I set out to learn a little Visual Basic For Applications (VBA) so that I could accomplish the task.

The first thing to do when looking to solve a problem for yourself is to look at This Chart. This Script shaves 15 minutes off a task that between me and the other people that use it is done almost daily. It took me less than 11 hours to get the code to work so I think I came out ahead. Hopefully this code will save you that much time in getting your solution working.

You’ll notice in the code that I reference two Rectangles. The first is used to start the VBA Script  and show when the information was last updated. The second lists the opened Workbooks and the date they were last updated. These Shapes and the associated code is optional.

Sub Merge()
'This text write doesn't actually show up due to the speed the function runs 
'I placed it here to try and get it to load, it might for you
ActiveSheet.Shapes("Rectangle 1").TextFrame.Characters.Text = "Merge Documents" & vbNewLine & "NO ERROR CHECKING!" & vbNewLine & vbNewLine & "RUNNING"

Dim MyArray(5, 3) As String, x As Integer
Dim SourceRange As Range
Dim WorkBk As Workbook
Dim SummarySheet As Worksheet
'Defined so I can reference anytime I want
Set SummarySheet = ThisWorkbook.Sheets("Sheet1")
Dim Heading As String
'I define this here so I can use LEN() on it later to customize the format
Heading = vbNewLine & "Dates of Change Sheets as of the last run" With SummarySheet.Shapes("Rectangle 2").TextFrame
 .Characters.Font.Color = vbWhite 'reset color
 .Characters.Text = Heading & vbNewLine 'write to box
End With

 'Set SummarySheet = ActiveWorkbook
 Dim DestRange As Range

'turn off things that slow down functions
Dim screenUpdateState As Long
screenUpdateState = Application.ScreenUpdating 'so you can reset at the end
Application.ScreenUpdating = False

'For my case, I have all the Workbooks in the same place
'If you have different locations you can hard link in the array
'If you needed to look at other than the first Sheet or
'in multiple sheets you could add another dimension with that value
Dim FolderPath As String
FolderPath = ActiveWorkbook.Path
    ChDrive FolderPath
    ChDir FolderPath
'I have hard coded each Workbook and the columns I desire
MyArray(0, 0) = "REPORT.xls"    'filename
MyArray(0, 1) = "A"             'First Desired Column
MyArray(0, 2) = "B"             'Second Desired Column

MyArray(1, 0) = "IMPACTS.xlsx"
MyArray(1, 1) = "C"
MyArray(1, 2) = "A"

MyArray(2, 0) = "hat.xlsx"
MyArray(2, 1) = "H"
MyArray(2, 2) = "A"

MyArray(3, 0) = "Report2.xlsx"
MyArray(3, 1) = "A"
MyArray(3, 2) = "C"

MyArray(4, 0) = "REPORT3.xlsx"
MyArray(4, 1) = "D"
MyArray(4, 2) = "A"

x = UBound(MyArray, 1) - LBound(MyArray, 1) - 1 'count MyArray for use later on

'Clear Sheet1 data
'I used .Delete here for a while but it moved my buttons and I didn't like that
'This is important in case the length of data changes
Columns(1).EntireColumn.ClearContents 
Columns(2).EntireColumn.ClearContents 

'define row_counter variable to keep track of where to paste the new data
Dim row_counter As Long
row_counter = 1

'write headers in Sheet1
Range("A" & row_counter) = "Document"
Range("B" & row_counter) = "Change Paper"
row_counter = row_counter + 1

'For to loop through MyArray
Dim i As Integer
For i = 0 To x
Dim WB As Workbook
'Write Workbooks name and the date it was last updated
With SummarySheet.Shapes("Rectangle 2").TextFrame
 .Characters.Text = .Characters.Text & vbNewLine & MyArray(i, 0) & " " & "  Saved: " & FileDateTime(MyArray(i, 0))
End With

'Opens the Workbooks in order, if it is already open there will be an error
Set WorkBk = Workbooks.Open(MyArray(i, 0))
         Dim LastRow As Long
'Count rows with data in selected column
LastRow = WorkBk.Worksheets(1).Cells(Rows.Count, MyArray(i, 1)).End(xlUp).Row
    Set SourceRange = WorkBk.Worksheets(1).Range(MyArray(i, 1) & "2:" & MyArray(i, 1) & LastRow)
    
    'Set the destination range to start at first column and be the same size as the source range.
        Set DestRange = SummarySheet.Range("A" & row_counter)
               Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
                 SourceRange.Columns.Count)
                      ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        'repeat for second column
        Set SourceRange = WorkBk.Worksheets(1).Range(MyArray(i, 2) & "2:" & MyArray(i, 2) & LastRow)
          Set DestRange = SummarySheet.Range("B" & row_counter)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
           
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
WorkBk.Close savechanges:=False 'Close Workbook
row_counter = row_counter + LastRow - 1 'keep track of where to paste new data
Next i

'turn back on things that slow down functions
Application.ScreenUpdating = screenUpdateState

'Call AutoFit on the destination sheet so that all data is readable.
    SummarySheet.Columns.AutoFit
    'Applies sorting filter
    Worksheets("Sheet1").Range("A:B").AutoFilter _
 field:=1, _
 VisibleDropDown:=True
Dim dt As String
dt = Format(CStr(Now), "General Date") 'timestamp
'Write Last Run date to button
ActiveSheet.Shapes("Rectangle 1").TextFrame.Characters.Text = "Merge Documents" & vbNewLine & "NO ERROR CHECKING!" & vbNewLine & vbNewLine & "Last Run on " & dt
'Style Header for first row
With SummarySheet.Shapes("Rectangle 2").TextFrame
 .Characters(1, Len(Heading)).Font.Color = vbBlue
 End With

End Sub