Macro to Combine Data from Different Workbooks into One Workbook

[rudevincy]

Hello

I need a macro that merges the data from 7 different workbooks and consolidates it on one tab in a the workbook that the macro is run.

Each file has multiple worksheets but will only need the data from the worksheet called AD_CNG, the columns in the worksheet AD_CNG is column A:J, but the number of rows differs, some of the worksheets may not have data only the headers (therefore for those files nothing would be copied). What I need is the macro to ask the user to select the folder to where the data files are (all data files will be in the same folder), copy the data and paste them into the workbook the macro is run on the PasteCombineData worksheet. I need the macro to paste just the data (no column headings) starting in the row immediately below.

So below are just examples of names for people to help me with the code, and I can go in and change the details afterward.

Here are the details:

1) Each data file has the data I need to copy in columns A:J.
2) In each data file, the column headings are in row 1, with the data beginning in row 2.
3) In each data file, the data that I need to copy is in the "AD_CNG" tab.
4) In the destination file, the data will be copied and pasted into the "PasteCombineData" tab.
6) The destination file is the file the macro is run from

I hope someone will can help

Thank you all very much in advance.


I found some code that and tried to change it to suit my needs but when the data is pasted into the PasteCombineData worksheet is is pasting the data multiple times... ie. in one file there is only 1 row of data and that row is copied but then pasted to PasteCombineData three times, I am not sure why this is happening .... also in the workbooks where there is no data it is still copying the header row and pasting it to the PasteCombineData worksheet.

Please see the code below....

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 = 7
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 7 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 = ThisWorkbook
Set OutSheet = OutBook.Sheets("PasteCombineData")

'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.Sheets("AD_CNG")

'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

 

[NdNoviceHlp]

U can trial this. HTH. Dave

Sub CombineDataFiles()
Dim DataBook As Object
Dim DataSheet 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

'initialize constants
MaxNumberFiles = 7
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", "*.xlsm"
.Show
End With

'error trap - don't allow user to pick more than 7 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
Exit Sub
End If
Application.ScreenUpdating = False
'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))
With Workbooks(DataBook.Name).Sheets("AD_CNG")
LastDataRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastDataCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
'if this is the first go-round, include the header
If FileIdx = 1 Then
'if this is NOT the first go-round, then skip the header
Workbooks(DataBook.Name).Sheets("AD_CNG").Range("A1:A" & LastDataRow).Copy _
Destination:=ThisWorkbook.Sheets("pastecombinedata").Range("A" & 1)
Else
If LastOutRow <> 1 Then
Workbooks(DataBook.Name).Sheets("AD_CNG").Range("A1:A" & LastDataRow).Copy _
Destination:=ThisWorkbook.Sheets("pastecombinedata").Range("A" & LastOutRow + 1)
End If
End If
'close the data book without saving
DataBook.Close False
'update the last outbook row
With Sheets("pastecombinedata")
LastOutRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Next FileIdx
Application.ScreenUpdating = True

'let the user know we're done!
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")

End Sub

ps. Please use code tags

 

[rudevincy]

This is great but it is still copying and pasting the headers, I dont need it to copy and paste the header just the data in row 2 and down

 

[NdNoviceHlp]

If LastOutRow <> 1 Then
Workbooks(DataBook.Name).Sheets("AD_CNG").Range("A2:A" & LastDataRow).Copy _
Destination:=ThisWorkbook.Sheets("pastecombinedata").Range("A" & LastOutRow + 1)
End If

HTH. Dave

 

[rudevincy]

I just realized that if any of the file selected does not have any data it is messing up the macro.. causing data to be pasted multiple times, pasting multiple headers... but if all the files selected has data then this macro works great.

How can the program tell if the file does not have data not to copy?

 

[NdNoviceHlp]

Trial #2 ...

Sub CombineDataFiles()
Dim DataBook As Object
Dim DataSheet 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

'initialize constants
MaxNumberFiles = 7
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", "*.xlsm"
.Show
End With

'error trap - don't allow user to pick more than 7 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
Exit Sub
End If
Application.ScreenUpdating = False
'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))
With Workbooks(DataBook.Name).Sheets("AD_CNG")
If .Range("A" & 2).Value = vbNullString Then
GoTo Below
End If
LastDataRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastDataCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
'if this is the first go-round, include the header
If LastOutRow = 1 Then
Workbooks(DataBook.Name).Sheets("AD_CNG").Range("A1:A" & LastDataRow).Copy _
Destination:=ThisWorkbook.Sheets("pastecombinedata").Range("A" & 1)
Else 'if this is NOT the first go-round, then skip the header
Workbooks(DataBook.Name).Sheets("AD_CNG").Range("A1:A" & LastDataRow).Copy _
Destination:=ThisWorkbook.Sheets("pastecombinedata").Range("A" & LastOutRow + 1)
End If
Below:
'close the data book without saving
DataBook.Close False
'update the last outbook row
With Sheets("pastecombinedata")
LastOutRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Next FileIdx
Application.ScreenUpdating = True

'let the user know we're done!
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")

End Sub

HTH. Dave

 

[rudevincy]

this is perfect... thank you so much for your patience and help.

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave