Getting above error in Title while trying to open the file in Macro to copy the data from that file to a central file(in which the macro is run). Checked the path and everything is fine. The Macro has opened and copied 10 files before the 11th instance of opening the file in the similar way however the error occurs on 11th file only. Tried changing position of the file access(by putting 12th file in sequence after 10th) however same error occurs.
Declared dr_x and fl_x as strings
Dim sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
dr_1 = "<path for the directory 1>"
Workbooks.Open (dr_1 & fl_1)
Windows("<file name 1.xlsx>").Activate
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Windows("<Target File Name.xlsm>").Activate
Sheets("Tab_File1").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Not quite sure what you're doing, but removing all the SELECT & ACTIVATE statements makes the code run a lot smoother.
The SourceFiles array contains the paths to all the workbooks you want to open and copy from.
Public Sub Test()
Dim TargetFile As Workbook, SourceFiles() As Variant
Dim tgtLastCell As Range, srcLastCell As Range
Dim tgtWrkSht As Worksheet, srcWrkSht As Worksheet
Dim fle As Variant
Dim wrkBk As Workbook
SourceFiles = Array("C:\MyPath\Book1.xlsx", _
"C:\MyOtherPath\Book2.xlsx")
Set TargetFile = ThisWorkbook 'If target sheet is in file containing this code.
'or
'Set TargetFile = Workbooks.Open("C:\SomePath\Book3.xlsx")
Set tgtWrkSht = TargetFile.Worksheets("Sheet1")
For Each fle In SourceFiles
'Find current last cell in target sheet.
Set tgtLastCell = LastCell(tgtWrkSht)
'Open source file, set reference to sheet1 and find the last cell containing data.
Set wrkBk = Workbooks.Open(fle)
Set srcWrkSht = wrkBk.Worksheets("Sheet1")
Set srcLastCell = LastCell(srcWrkSht)
'Copy & paste contents of sheet on to end of target sheet.
With srcWrkSht
.Range(.Cells(1, 1), srcLastCell).Copy Destination:=tgtWrkSht.Cells(tgtLastCell.Row + 1, 1)
End With
'Close source workbook.
wrkBk.Close False
Next fle
End Sub
Public Function LastCell(wrkSht As Worksheet) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
The answer I got for the above issue is below -
Sub Consolidate()
Path = "\\Source-Path\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
where "\Source-Path\" is the folder where all source files(from where the data is to be copied) are stored.
Related
I have a challenge on achieving the below project, kindly please assist:
I have four source workbooks with names(GK,SK,RJ and TB).
Each workbook(GK,SK,RJ and TB) have three worksheets with the same names(products, channels, and sales).
I have destination workbook called consolidated workbook with the same worksheets names(products, channels, and sales) like those of the four source workbooks.
All workbooks(source + destinations) are in the same folder.
Iam requesting VBA code that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Currently I have the below code but whenever I ran it copies everything from worksheets on the source workbooks and paste to worksheets in consolidated workbook which result to duplicated data.
All the source workbook have worksheets with the "DATE" as a first column in each worksheet table column.
Destination workbook also have the same worksheet names and the same columns structure on each worksheet are the same as of those source worksheet.
Kindly advise what should I amend so that the code will that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see the amended code:
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range,
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As
Range
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
On Error Resume Next
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
Set fndRng = sh.Range("A:A").Find(date_to_find,LookIn:=xlValues,
searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
On Error GoTo 0
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see how consolidated workbook appear(the sheet names and column format are exactly the same as of the source workbooks.)
CONSOLIDATED WORKBOOK
The following line can be used to find the latest date loaded on your consolidated sheet:
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
The following lines can be used on a worksheet (sh) to create a range (for copying) that starts after the latest_date_loaded down to the bottom of the table. You'll therefore need to ensure this is in date order.
Dim fndRng As Range, start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As Range
date_to_find = latest_date_loaded
Set fndRng = sh.Range("A:A").Find(date_to_find, LookIn:=xlValues, searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
EDIT
Here is a rework of your code, using some of the lines/ideas I've mentioned above.
Sub Copy_From_All_Workbooks()
'declarations
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, _
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As _
Range, latest_date_loaded As Date, consolidated_wb As Workbook
'turn off screen updating for user experience
'Application.ScreenUpdating = False
'set a reference to the consolidated workbook
Set consolidated_wb = ThisWorkbook
'read parent folder of consolidated workbook
wb = Dir(consolidated_wb.Path & "\*")
'perform this loop until no more files
Do Until wb = ""
'make sure it doesn't try to open consolidated workbook (again)
If wb <> consolidated_wb.Name Then
'open found source workbook
Workbooks.Open consolidated_wb.Path & "\" & wb
'cycle through each sheet (sh)
For Each sh In Workbooks(wb).Worksheets
'on that sheet, find the latest date already existing
latest_date_loaded = Application.WorksheetFunction.Max(consolidated_wb.Sheets(sh.Name).Range("A:A"))
'find the last occurence of that date in column A
Set fndRng = sh.Range("A:A").Find(latest_date_loaded, LookIn:=xlValues, _
searchdirection:=xlPrevious)
'if you find that date already then..
If Not fndRng Is Nothing Then
'set the top row to where you found it, plus one
start_of_copy_row = fndRng.Row + 1
Else
'otherwise, it's a new sheet, start on row two
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
'find the end of the table, using column A's contents
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
'make sure there's something to copy
If end_of_copy_row >= start_of_copy_row Then
'create a reference to the block of cells to copy
Set range_to_copy = sh.Range(start_of_copy_row & ":" & end_of_copy_row)
'copy that range
range_to_copy.Copy
'paste them, values only
consolidated_wb.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'clear copy markings from screen
Application.CutCopyMode = False
Else
'otherwise, do nothing here
End If
Next sh
'close the source workbook
Workbooks(wb).Close False
End If
'get next potential filename
wb = Dir
Loop
'turn back on screen updating
Application.ScreenUpdating = True
End Sub
I'm creating a script to import data from a series of Workbooks in a declared folder.
The Workbook may contain multiple sheets as dictated by the values on the "DD Meeting" tab, whereby if the cell value begins with "Code_", there will be no sheet to import from.
I'm trying to create a script that looks for a sheet name based on these values, copies the data, then looks for the next sheet to resume the copy job.
I can copy from the first sheet fine, however the script then has trouble searching for the next sheet name using an activecell instead of the declaring a specific cell (I need to offset hence can't name the cell).
This works:
Set wsData = wb.Sheets(Worksheets("DD Meeting").Range("D6").Value)
This doesnt:
Set wsData = wb.Sheets(Worksheets("DD Meeting").ActiveCell.Value)
Any help is appreciated, thanks.
Sub ImportInfo()
Dim sPath As String 'path of folder containing info
Dim sFileName As String '
Dim wsSummary As Worksheet 'worksheet to paste data to in this workbook
Dim wsData As Worksheet 'sheet with data to copy
Dim wb As Workbook 'workbooks to loop thorugh
Dim nr As Long 'next row to add the data
'Get the worksheet to add the info to
Set wsSummary = ThisWorkbook.Worksheets("Sheet1")
'first row is 2
nr = 2
sPath = "C:\Users\sthorley\Downloads\Test\" '[COLOR=#ff0000][B]Change as required[/B][/COLOR]
sFileName = Dir(sPath & "*.xlsm")
Do While sFileName <> ""
'open workbook
Set wb = Workbooks.Open(Filename:=sPath & sFileName, ReadOnly:=True)
wb.Sheets(Worksheets("DD Meeting").Range("D6").Value).Activate
'get the sheet to copy from
Set wsData = wb.Sheets(Worksheets("DD Meeting").Range("D6").Value)
Worksheets("DD Meeting").Select
Worksheets("DD Meeting").Range("D6").Select
'get the data
Do While ActiveCell.Value <> "*Code*"
wsSummary.Range("A" & nr).Value = wsData.Range("B5").Value
wsSummary.Range("B" & nr).Value = wsData.Range("B3").Value
wsSummary.Range("C" & nr).Value = sFileName
wsData.Activate
wsData.Range("A5").Select
' Summary Key Points
wsData.Cells.Find(What:="Summary/Key points", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
wsSummary.Range("D" & nr).Value = ActiveCell.Offset(2).Value
'get next row
nr = nr + 1
Worksheets("DD Meeting").Select
ActiveCell.Offset(1).Select
'get the sheet to copy from
Set wsData = Nothing
Set wsData = wb.Sheets(Worksheets("DD Meeting").ActiveCell.Value)
Loop
'close the workbook
wb.Close savechanges:=False
'get next workbook name
sFileName = Dir
Loop
End Sub
I have a list of *.xlsm file names on a sheet named "DB" in range E961 to E1010 (50 rows) and I'm trying to create a macro that runs through this list and open the corresponding files in the set directory, runs some code and close the file, moving on to the next file on the list - repeating this operation every 5 minutes.
The directory contains 400+ xlsm files, and the list in E961 will typically be less than 50 files - so I'm not trying to open all the files in the directory. That already happens once a day at a set time.
But I am trying to open these "shortlisted" files and update them every 5 minutes for example. I tried different combinations of code but can't seem to get it working.
The main file containing this code is also in the same directory to allow relative linking to the other 400+ files, hence the ThisWorkbook.Path code.
Edited code below:
Sub UPDATE()
Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("DB")
Dim inputRange As Range
Set inputRange = .Range("E961", .Cells(.Rows.Count, 5).End(xlUp))
End With
Dim directory As String: directory = ThisWorkbook.Path & "\"
Dim fileName As String
Dim r As Range
Dim xlwb As Workbook
For Each r In inputRange
If r <> vbNullString Then
fileName = Dir(directory & r & ".xl??*")
Set xlwb = Workbooks.Open(directory & fileName)
Application.DisplayAlerts = False
ActiveWorkbook.RefreshAll
If Range("A4") > Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0) Then
Worksheets("DB").Range("A4:L4").Select
Worksheets("DB").Range("A4").Activate
Selection.Copy
Sheets("DB").Select
Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(1). _
PasteSpecial Paste:=xlPasteValues, _
SkipBlanks:=True, Transpose:=False
Application.CutCopyMode = False
Else
End If
If Range("A4") = Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0) Then
Worksheets("DB").Range("A4:L4").Select
Worksheets("DB").Range("A4").Activate
Selection.Copy
Sheets("DB").Select
Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0). _
PasteSpecial Paste:=xlPasteValues, _
SkipBlanks:=True, Transpose:=False
Application.CutCopyMode = False
End If
xlwb.Close True
End If
Next r
Application.ScreenUpdating = True
End Sub
The error comes from "Set xlwb = (sht.Cells(Row, 1).Value)" because it is trying to open a sheet as a workbook, but I have no idea how to fix it... or everything is wrong ...
Thanks for the help!
Try this piece it should work thought it will only open and close workbooks until you give it some code to work them:
Option Explicit
Sub UPDATE()
Application.ScreenUpdating = False
'if you are only using here your wb and sht variables, use a With, there is no need to use variables
With ThisWorkbook.Worksheets("DB")
Dim inputRange As Range
'It is preferable to do xlUp because you could find some empty cells in between.
Set inputRange = .Range("E961", .Cells(.Rows.Count, 5).End(xlUp))
End With
Dim directory As String: directory = ThisWorkbook.Path & "\"
Dim fileName As String
Dim r As Range
Dim xlwb As Workbook
For Each r In inputRange
If r <> vbNullString Then
fileName = Dir(directory & r & ".xl??*") 'don't know if your cell has the extension
Set xlwb = Workbooks.Open(directory & fileName)
'some code
xlwb.Close False 'False won't save the workbook, use True if you want it to be saved.
End If
Next r
Application.ScreenUpdating = True
End Sub
I have a master workbook in one folder and 100+ child workbooks in a different folder.
Every week I need to copy a specific range of cells from the child workbooks (sheet name is same for all child books) to master workbook (specific sheet).
I tried a few samples but didn't work out.
I fully agree with guys who told you that none will write the code for you, but you are lucky that I have that already written and there may be other people looking for same info, so here it is.
Put the code to module in your master workbook and replace some data as commented:
Option Explicit
Sub GoThroughFilesAndCopyData()
Dim BrowseFolder As String
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim shtWork As Worksheet
Dim lngRow As Long
Dim i As Long: i = 1
Dim strPath As String
Dim MasterSheet As Worksheet
Dim ChildSheet As Worksheet
Application.ScreenUpdating = False
' selecting the folder to look files in
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with child workbooks"
.Show
On Error Resume Next
Err.Clear
BrowseFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
Set FSO = CreateObject("Scripting.FileSystemObject") ' creating filesystem object
Set oFolder = FSO.getfolder(BrowseFolder) ' creating folder object
Set MasterSheet = ThisWorkbook.Sheets("masterworksheet_name") 'replace masterworksheet_name with the name of your worksheet in master workbook
For Each FileItem In oFolder.Files 'looking through each file
If UCase(FileItem.Name) Like "*.XLS*" Then 'try open only excel files
i = MasterSheet.Cells(Rows.Count, 1).End(xlUp).row + 1 ' find last not empty row and get a next one which is empty
Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
Set ChildSheet = Workbooks(FileItem.Name).Sheets("worksheet_name") 'worksheet_name - replace with child sheet name
With ChildSheet ' replace your_range_to_copy with the range on a child sheet you want to copy
Range("your_range_to_copy").Copy Destination:=MasterSheet.Cells(i, column_number) 'i - is the number of last empty row, replace column_number - must be the column number of range to insert
.Parent.Close SaveChanges:=False 'close child workbook without saving
End With
End If
Next
Application.ScreenUpdating = True
End Sub
This will do what you want.
Copy a range of each sheet
Note: This example use the function LastRow
This example copy the range A1:G1 from each worksheet.
Change the range in this code line
'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Also . . .
'Common Functions required for all routines
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Copying worksheets from multiple workbooks into current workbook
Hi I was wondering if anybody if you guys could help me out?
Im trying to copy multiple workbooks and just save it into only one worksheet.
I have 2000 diffrent workbooks with the diffrent amount of rows, The ammount of cells is the same and it dosent change and they are all at the first sheet in every workbook.
Im new with this kind of stuff so i'm thankfull for all help u can offer, I cant make it work. I'm using excel 2010
This is what I got atm:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = “C:\test\”
MyFile = Dir("test\")
Do While Len(MyFile) > 0
If MyFile = "master.xlsm" Then
Exit Sub
End If
Range(Range("a1"), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Name = "PivotData"
Workbooks.Open (Filepath & MyFile)
Range("A2:AD20").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 1))
MyFile = Dir
Loop End
Sub
I've re-written your code by applying what I posted in the comment.
Try this out: (I stick with your logic using the DIR function)
Sub test()
Dim MyFile As String, MyFiles As String, FilePath As String
Dim erow As Long
'~~> Put additional variable declaration
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
FilePath = "C:\test\"
MyFiles = "C:\test\*.xlsx"
MyFile = Dir(MyFiles)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Set your declared variables
Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
Set wsMaster = wbMaster.Sheets("Sheet1") 'replace Sheet1 to suit
Do While Len(MyFile) > 0
'Debug.Print MyFile
If MyFile <> "master.xlsm" Then
'~~> Open the file and at the same time, set your variable
Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
Set wsTemp = wbTemp.Sheets(1) 'I used index, you said there is only 1 sheet
'~~> Now directly work on your object
With wsMaster
erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row
'~~> Copy from the file you opened
wsTemp.Range("A2:AD20").Copy 'you said this is fixed as well
'~~> Paste on your master sheet
.Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
End With
'~~> Close the opened file
wbTemp.Close False 'set to false, because we opened it as read-only
Set wsTemp = Nothing
Set wbTemp = Nothing
End If
'~~> Load the new file
MyFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I've commented the code to help you modify it to suit your needs.
I you got stuck again, then just go back here and clearly state your problem.
Try this out:
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