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] - vba

Question

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

Answer 1

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