Excel VBA Macro to copy the used cells in mutiple excel in to one excel - vba

I am new to VBA script. The below macro copies the particular cell range in the macro. I would like to copy all the excel file rows in a particular folder in to one excel sheet.
I tried this command for copying all the range instead of one cell, but its not working.
Set sourceRange = .Range(.Cells(1, 1), .End(xlDown))
Source code
Sub copydata()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
'Fill in the path\folder where the files are
MyPath = "C:\Users\yureka\tryexcel"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
MsgBox mybook
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
'Set sourceRange = .Range("A1:C1")
Set sourceRange = .Range(.Cells(1, 1), .End(xlDown))
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 = MyFiles(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:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

edited after OP's further clarification
to use Column A to F used rows you can us:
Set sourceRange = .Range("F1", .Cells(.Rows.Count,1).End(xlUp))
Set sourceRange = Intersect(.UsedRange, .Range("A:F"))

Related

I am trying to have this macro include the ability to copy data from multiple worksheets in a workbook but it will only copy from the first worksheet [closed]

Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 4 years ago.
Improve this question
This is my data below.
The code works just doesn't fit my requirements. I need to add the functionality that will allow me to pull data from multiple worksheets in 1 workbook but currently it will only pull the data from 1 worksheet in 1 workbook.
I've included the code to go through different worksheets but as of now the code will only extract data from 1 worksheet in 1 workbook.
Any help is greatly appreciated. Thanks!
Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
' Change this to the path\folder location of your files.
MyPath = "C:\Users\mp180423\Desktop\Gas"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
Debug.Print ws.Name
Next
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(3)
Set sourceRange = .Range("A15:B20")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses 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 "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column A.
For Each ws In Worksheets
ws.Activate
Debug.Print ws.Name
Next
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
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
Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$66").AutoFilter Field:=2, Criteria1:= _
"Kilowatt hours used Current period"
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
MsgBox ("Merge Completed.")
End Sub
I expect that the single worksheet from the single workbook which this code was correctly working for, would be the only workbook with at least 3 worksheets.
When selecting the range you have:
With mybook.Worksheets(3)
Set sourceRange = .Range("A15:B20")
End With
Note that this restricts the data to the range from only the 3rd (third) worksheet from every workbook.
Also note that on the line prior, you have:
On Error Resume Next
This would effectively mask the errors coming from attempting to extract data from all the non-existing 3rd worksheets. For the workbook with at least 3 worksheets, since the With mybook.Worksheets(3) is hard-coded into your code, this was the only worksheet the data was pulled from.
(And the reason it wasn't duplicated for each worksheet in that workbook, is because the cycles through the worksheets were restricted to the Debug.Print lines. The code for the data-moving only cycled through once for each workbook)
Below, you will see three (3) sections:
Change Details.
This is to help high-light the changes I made to your code so that it cycles through the data-moving for each worksheet, pulling once from each worksheet.
Corrected
This is for ease of copy/pasting the code
Original
This is to maintain a copy of the original code I based my answer off of (in case of changes).
Change Details
From original:
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
Debug.Print ws.Name
Next
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(3)
Set sourceRange = .Range("A15:B20")
End With
Changed to:
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
Dim ws As Worksheet
If Not mybook Is Nothing Then
For Each ws In Worksheets
On Error Resume Next
' Change this range to fit your own needs.
With ws
Set sourceRange = .Range("A15:B20")
End With
Top-half:
Although I kept the Dim ws As Worksheet, I removed the Debug.Print cycle through all worksheets, as it had no effect on any other code.
Lower-half:
Added a For Each ws In Worksheets around the functional code (which required adding Next ws above mybook.Close savechanges:=False), and shifted the with statement from With mybook.Worksheets(3) to With ws
Since there was another extraneous Debug.Print cycle right before the file name was added to column A, I replaced it with Debug.Print ws.Name & ": #" & FNum to be a bit more informative.
Corrected
Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
' Change this to the path\folder location of your files.
MyPath = "C:\Users\mp180423\Desktop\Gas"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
' Added cycle through worksheets
Dim ws As Worksheet
If Not mybook Is Nothing Then
For Each ws In Worksheets
On Error Resume Next
' Change this range to fit your own needs.
' Shifted reference to current worksheet-of-interest
With ws
Set sourceRange = .Range("A15:B20")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses 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 "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
' Prints file name and index number in immediate window.
Debug.Print ws.Name & ": #" & FNum
' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
'Cycles through next worksheet-of-interest
Next ws
mybook.Close savechanges:=False
End If
Next FNum
BaseWks.Columns.AutoFit
End If
Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$66").AutoFilter Field:=2, Criteria1:= _
"Kilowatt hours used Current period"
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
MsgBox ("Merge Completed.")
End Sub
Original
Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
' Change this to the path\folder location of your files.
MyPath = "C:\Users\mp180423\Desktop\Gas"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
Debug.Print ws.Name
Next
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(3)
Set sourceRange = .Range("A15:B20")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses 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 "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column A.
For Each ws In Worksheets
ws.Activate
Debug.Print ws.Name
Next
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
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
Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$66").AutoFilter Field:=2, Criteria1:= _
"Kilowatt hours used Current period"
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
MsgBox ("Merge Completed.")
End Sub

Compile Multiple .xls files in Shared Drive

I'm looking to compile several daily xls files into one master file. The location is in a shared folder but I can also copy them to my desktop. I'm using the developer tab in Excel and have researched some other sources online.
Sub GetSheets()
Path = "C:\Desktop\test_for_margaret\"
Filename = Dir(Path & "*.xls")
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
My VBA knowledge is limited but I figure there is more to change the lines following the Path.
I can't seem to comment (reputation limit), so I'm posting as an answer.
As braX points out, you are looping through the directory looking for "*.xls" files. If your files are ".xlsx" then you will not be finding any matches.
Update your filename string to be defined as below:
Filename = Dir(Path & "*.xls*")
The additional wildcard character will allow you to see both .xls files and .xlsx. Of course, this is provided that the path supplied is correct.
Compile or merge? The following script will merge all Excel files in a folder.
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
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 = MyFiles(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:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
https://www.rondebruin.nl/win/s3/win008.htm

Copy sheets from different workbooks into a single workbook

I'm trying to copy the first sheet from multiple workbooks into a new workbook, on separate sheets, and summarise the data in one more sheet at the end of the workbook.
At the moment my workbook creation isn't really working. It copies the first sheet into a new workbook but then stops working:
error 9, subscript out of range
Sub MergeSelectedWorkbooks()
Dim SummaryBook As Workbook
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim SelectedFiles() As Variant
Dim NRow As Long
Dim FileName As String
Dim NFile As Long
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Set SummaryBook = Workbooks.Add(xlWBATWorksheet)
FolderPath = "Path here"
ChDrive FolderPath
ChDir FolderPath
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
Nrow = 1
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
Set SummarySheet = Workbook.Worksheets(NRow) 'this is what seems to be the reason it doesn't work
Set WorkBk = Workbooks.Open(FileName)
Application.Run WorkBk.Name & "!Macro" 'this runs a macro in the workbook that I want to copy the sheet from
Set SourceRange = WorkBk.Worksheets(1).Range("A1:G21")
Set DestRange = SummarySheet.Range("A1:G21")
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
DestRange.Value = SourceRange.Value
NRow = NRow + 1
WorkBk.Close savechanges:=False
Next NFile
SummarySheet.Columns.AutoFit
End Sub
Any ideas?
Here you go.
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
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 = MyFiles(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:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
https://www.rondebruin.nl/win/s3/win008.htm

Consolidate Excel Files into Master File (VBA)

Could someone please take a look at my code and tell me what Iā€™m doing wrong? I'm trying to consolidate a group of excel files that are in a folder into a master Excel file. My logic seems right but for some reason, the data is not pasting into the master file from the source files. Thank you all in advance!
Sub ConsolidateMAR()
'
'
'
Dim lastRow As Long
Dim MyFolder As String
Dim myFile As String
Dim wbkSource As Workbook
Dim wkbDest As Workbook
Set wkbDest = Workbooks.Open("C:\Users\xxxxx\Desktop\MAR Test Master File.xlsx")
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
myFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While myFile <> ā€œā€
'Opens the file and assigns to the wbkSource variable for future use
Set wbkSource = Workbooks.Open(FileName:=MyFolder & myFile)
'Replace the line below with the statements you would want your macro to perform
If Err.Number <> 0 Then
MsgBox ("Unable to open file " & myFile)
End If
On Error GoTo 0
wbkSource.ActiveSheet.Unprotect Password:="adgiam"
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
Rows("3:3").Select
Selection.AutoFilter
Rows("3:3").Select
Selection.AutoFilter
lastRow = wbkSource.ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
Range("A4:W" & lastRow).Select
Selection.Copy
Application.DisplayAlerts = False
erow = wkbDest.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
wkbDest.ActiveSheet.Paste Destination:=Sheets(1).Range(Cells(erow, 1), Cells(erow, 23))
wbkSource.Close SaveChanges:=False
myFile = Dir 'DIR gets the next file in the folder
Loop
wkbDest.Close SaveChanges:=True
Application.ScreenUpdating = True
MsgBox "Macro has completed! Woot! Woot!"
End Sub
I had to do something similar, but chose to move the sheets into the new workbook.
See So, I have 6 "master" files to then divide into 40 separate files
Those select statements are pretty dangerous. Try to avoid those and just make a direct reference to the object you want to control.
Something like this should work for you.
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
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 = MyFiles(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:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Also, check out the AddIn below.
http://www.rondebruin.nl/win/addins/rdbmerge.htm

Selecting a range on merged workbooks

I also need to change the "destination" of the merged data to be pasted starting on cell row 4.The code I found in Microsoft.com (with a little modification thanks to the answer below) is as follow
Sub Button1_Click()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
' Change this to the path\folder location of your files.
MyPath = "C:\Documents and Settings\laragon2\Desktop\Week's Routers"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.
Set BaseWks = ThisWorkbook.Sheets("Routers")
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(1)
Set sourceRange = .Range("A4", .Range("E700").End(xlUp))
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses 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 "There are not enough rows in the target worksheet."
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 = MyFiles(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("b4")
' Copy the values from the source range
' to the destination range.
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:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
The source range is being set in the line immediately after: ' Change this range to fit your own needs. It looks like this:
Set sourceRange = .Range("A1:C1")
The destination is being set in the line immediately after the comment indicating: ' Set the destination range. It looks like this:
Set destrange = BaseWks.Range("B" & rnum)
EDIT Here is an example. Create an empty workbook. Put some values in cells A1:A5 on sheet 1. The do this:
Sub CopyRangeToRange()
Dim sourceRange As Range
Dim destRange As Range
Set sourceRange = Range("A1:A5")
Set destRange = Sheets(2).Range("A1")
With sourceRange
Set destRange = destRange.Resize( _
.Rows.Count, .Columns.Count)
End With
Sheets(2).Activate
destRange.Activate
destRange.Value = sourceRange.Value
End Sub
This is the exact same method I propose above. If this works, but the macro you are writing does not work, you need to debug where it is going wrong, because the method is the same.
EDIT #2
After trying this on your workbook, I think this is what you're after. I believe I commented all of my changes, which you can find by the '## comments. Almost all of the changes applied within the With sourcerange block. I also changed the initial value of rnum to 4, since that seems to be where the data should begin being pasted in the Routers worksheet, and modified the way rnum increments for each file in the loop.
Sub Button1_Click()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long, mybook As Workbook
Dim BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
' Change this to the path\folder location of your files.
MyPath = "C:\Documents and Settings\laragon2\Desktop\Week's Routers"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Set the destination worksheet:'
Set BaseWks = ThisWorkbook.Sheets("Routers")
'## set rnum to 4 because we begin pasting data in row 4... ##'
rnum = 4
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(1)
Set sourceRange = .Range("A4", .Range("E4:E700").End(xlUp)) '## changed dz ##'
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses 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 "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column A.
BaseWks.Activate
With sourceRange
''## changed to make this range the same number of rows as sourceRange ##'
BaseWks.Cells(rnum, 1). _
Resize(.Rows.Count).Value = MyFiles(FNum)
'## moved this code and changed to begin at the last non-blank row in column A, but use column B ##'
'## resize the destrange to the same dimensions as sourcerange ##'
Set destrange = BaseWks.Cells(rnum, 1). _
Resize(.Rows.Count, .Columns.Count).Offset(, 1)
'## Insert the source values in the destination range ##'
destRange.Value = .Value
'## increment rnum to the next appropriate value ##'
rnum = rnum + .Rows.Count
End With
'## Removed as redundant
'With sourceRange
' Set destrange = destrange. _
' Resize(.Rows.Count, .Columns.Count)
'End With
' Copy the values from the source range
' to the destination range.
'## This has been moved to above. ##
' destrange.Value = sourceRange.Value
End If
End If
mybook.Close savechanges:=False
End If
Next FNum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub