Copy from multiple workbooks into one new workbook

P

powercell99

Board Regular
Joined
May 14, 2014
Messages
75
I found a great code for copying worksheets from multiple workbooks (up to 2000 workbooks) into one new workbook. Thanks Dan Wagner for writing it. It works perfectly for 99% of the copying/merging that i do. The only issue with the code is that it only copies from the active sheet in the other workbooks. I need it to copy from a specific sheet ("Travel") in all of the workbooks that i select. I've tried many ways to edit the code to change the activesheet to "Travel" but i cannot get it to work. Any help on editing this code would be enormously appreciated :-) H E L P . . .


<code>Option Explicit Sub CombineDataFiles() Dim DataBook As Workbook, OutBook As Workbook Dim DataSheet As Worksheet, OutSheet As Worksheet Dim TargetFiles As FileDialog Dim MaxNumberFiles As Long, FileIdx As Long, _ LastDataRow As Long, LastDataCol As Long, _ HeaderRow As Long, LastOutRow As Long Dim DataRng As Range, OutRng As Range 'initialize constants MaxNumberFiles = 2001 HeaderRow = 1 'assume headers are always in row 1 LastOutRow = 1 'prompt user to select files Set TargetFiles = Application.FileDialog(msoFileDialogOpen) With TargetFiles .AllowMultiSelect = True .Title = "Multi-select target data files:" .ButtonName = "" .Filters.Clear .Filters.Add ".xlsx files", "*.xlsx" .Show End With 'error trap - don't allow user to pick more than 2000 files If TargetFiles.SelectedItems.Count > MaxNumberFiles Then MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...") Exit Sub End If 'set up the output workbook Set OutBook = Workbooks.Add Set OutSheet = OutBook.Sheets(1) 'loop through all files For FileIdx = 1 To TargetFiles.SelectedItems.Count 'open the file and assign the workbook/worksheet Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx)) Set DataSheet = DataBook.ActiveSheet 'identify row/column boundaries LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 'if this is the first go-round, include the header If FileIdx = 1 Then Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol)) Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol)) 'if this is NOT the first go-round, then skip the header Else Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol)) Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol)) End If 'copy the data to the outbook DataRng.Copy OutRng 'close the data book without saving DataBook.Close False 'update the last outbook row LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Next FileIdx 'let the user know we're done! MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!") End Sub</code></pre>
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
CAn you repost the code using Code Tags...it's far easier to modify and debug
See the bottom of my tag
 
Upvote 0
Thanks Michael. Appreciate you looking at it.


Code: 
Option Explicit
Sub Merge()

Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
    LastDataRow As Long, LastDataCol As Long, _
    HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range

'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1

'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add "*.* files", "*.*"
    .Show
End With

'error trap - don't allow user to pick more than 2000 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
    MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
    Exit Sub
End If

'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)

'loop through all files
For FileIdx = 1 To TargetFiles.SelectedItems.Count

    'open the file and assign the workbook/worksheet
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    Set DataSheet = DataBook.ActiveSheet
    ' I need it to copy out of worksheets named "Travel"

    'identify row/column boundaries
    LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    'if this is the first go-round, include the header
    If FileIdx = 1 Then
        Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
    'if this is NOT the first go-round, then skip the header
    Else
        Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
    End If

    'copy the data to the outbook
    DataRng.Copy OutRng

    'close the data book without saving
    DataBook.Close False

    'update the last outbook row
    LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Next FileIdx

ActiveSheet.Select
    On Error Resume Next
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
        Cells.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
   Cells.Select
    Selection.Copy
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AB1").Select
    Selection.ClearContents
    Range("AB2").Select
        
End With

'let the user know we're done!
MsgBox ("The Macro has aggregated " & TargetFiles.SelectedItems.Count & " files!")

End Sub
 
Upvote 0
Modified, UNTESTED code below will do what you want, you just need to pass the sheet name in as a parameter when you call the Sub...

Code: 
Option Explicit
Sub Merge(sourceSheetName As String)

Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
    LastDataRow As Long, LastDataCol As Long, _
    HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range

'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1

'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add "*.* files", "*.*"
    .Show
End With

'error trap - don't allow user to pick more than 2000 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
    MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
    Exit Sub
End If

'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)

'loop through all files
For FileIdx = 1 To TargetFiles.SelectedItems.Count

    'open the file and assign the workbook/worksheet
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    ' //////////////////////////////////////////////////////////
    On Error GoTo sheetDoesNotExist
    'Skip any Books that do not contain the required sheet
    Set DataSheet = DataBook.Sheets(sourceSheetName)
    ' I need it to copy out of worksheets named "Travel"
    ' //////////////////////////////////////////////////////////
    ' Just pass the source sheet name in when calling

    'identify row/column boundaries
    LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    'if this is the first go-round, include the header
    If FileIdx = 1 Then
        Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
    'if this is NOT the first go-round, then skip the header
    Else
        Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
    End If

    'copy the data to the outbook
    DataRng.Copy OutRng

    'close the data book without saving
    DataBook.Close False

    'update the last outbook row
    LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

sheetDoesNotExist:
Next FileIdx

ActiveSheet.Select
    On Error Resume Next
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
        Cells.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
   Cells.Select
    Selection.Copy
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AB1").Select
    Selection.ClearContents
    Range("AB2").Select
        
End With

'let the user know we're done!
MsgBox ("The Macro has aggregated " & TargetFiles.SelectedItems.Count & " files!")

End Sub
 
Upvote 0
Cool blue; That WORKED LIKE A CHARM. I also forgot to address the possibility of what to do when workbooks dont contain the sheet name that i'm looking for, so Thanks for catching that for me as well. You Da man!! I really appreciate your help. I'll get a lot of use out of this. :-):)

Thanks very much for your help and knowledge.
Cool blue said:
Modified, UNTESTED code below will do what you want, you just need to pass the sheet name in as a parameter when you call the Sub...

Code: 
Option Explicit
Sub Merge()

Dim sourceSheetName As String
Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
    LastDataRow As Long, LastDataCol As Long, _
    HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range

'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1

'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add "*.* files", "*.*"
    .Show
End With

'error trap - don't allow user to pick more than 2000 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
    MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
    Exit Sub
End If

'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)

'loop through all files
For FileIdx = 1 To TargetFiles.SelectedItems.Count

    'open the file and assign the workbook/worksheet
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    ' //////////////////////////////////////////////////////////
    On Error GoTo sheetDoesNotExist
    'Skip any Books that do not contain the required sheet
    Set DataSheet = DataBook.Sheets("Travel")
     
    ' //////////////////////////////////////////////////////////
    ' Just pass the source sheet name in when calling

    'identify row/column boundaries
    LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    'if this is the first go-round, include the header
    If FileIdx = 1 Then
        Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
    'if this is NOT the first go-round, then skip the header
    Else
        Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
    End If

    'copy the data to the outbook
    DataRng.Copy OutRng

    'close the data book without saving
    DataBook.Close False

    'update the last outbook row
    LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

sheetDoesNotExist:
Next FileIdx

ActiveSheet.Select
    On Error Resume Next
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
        Cells.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
   Cells.Select
    Selection.Copy
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AB1").Select
    Selection.ClearContents
    Range("AB2").Select
        
End With

'let the user know we're done!
MsgBox ("The Macro has aggregated " & TargetFiles.SelectedItems.Count & " files!")

End Sub
Click to expand...
 
Upvote 0
Hi Code Blue,

I've been trying to figure out how to set a default source folder location for when the Open Dialog box opens. I'm really confused. How could i change this code to force the open dialog box to : file:\\collaboration.test.com\sites\Travel\DataDollection\Division\PDG (just an example location), so that they select from the files in that location. If they want to navigate away from that location and select other files they can, but having it start in that location would be best.

Any suggestions?? Thanks in advance



powercell99 said:
Cool blue; That WORKED LIKE A CHARM. I also forgot to address the possibility of what to do when workbooks dont contain the sheet name that i'm looking for, so Thanks for catching that for me as well. You Da man!! I really appreciate your help. I'll get a lot of use out of this. :-):)

Thanks very much for your help and knowledge.
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
315
RoryA
RoryA
D
  • Solved
VBA to copy only matching data from 2 csv workbooks into the "MasterCSV"
2
Replies
18
Views
881
Peter_SSs
Peter_SSs
M
  • Question Question
Copy File Names to Destination File
Replies
2
Views
303
metalscuba
M
T
  • Question Question
Automatically Copying Data To A New Workbook When Closing A Workbook
Replies
4
Views
383
Tmini
T
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
261
Logit
Logit

Forum statistics

Threads
1,223,107
Messages
6,170,137
Members
452,304
Latest member
Thelingly95

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top