R
Ray
Hi -
I need to 'consolidate' data into one Master Workbook -- my current
code is below. The data currently sits in approx 30 workbooks and is
spread across a number of worksheets within each WB. All WB are set
up exactly the same way -- same sheet names, etc. The Master WB also
has the same Sheet names (to keep things simple).
My code worked fine when just hitting one worksheet within each WB.
However, when I modified the code to pull from all of the sheets, it
didn't work at all! My modification was to activate the vArr code and
change all references to the single worksheet to use the 'ws'
reference. When I run the code now, the first WB opens and then the
code stops.
What's causing this and how do I fix it?
A couple of other small things aren't working -- there's code to
isolate the store number from the name of each target WB and insert it
into Column A. It should put this store number next to EACH ROW that
is transferred, but it currently just puts it in the first row.
When all data has been pulled from the target WBs, I want all blank
rows to be deleted from each data tab in the Master WB. A blank row
is any row where cells Ax & Bx (where x is row #) are blank.
Any help is greatly appreciated ... here's my current code:
Sub Example2()
Dim MyPath, getstore As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount, x As Long
Dim Fnum, i As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim ws As Worksheet
MyPath =" \\server\folder1\folder2\folder3\"
' the following are sheets within each target WB
vArr = Array("Sales Act", "Hours Act", "Sales LY", "Sales Goal",
"Hours LY", "Hours Goal", "Sales Forecast", "Hours Forecast")
'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 & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets("Hours Act").Cells.Clear
rnum = 2
'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
'Loop through all files in the array(myFiles) and selected sheets
in array(vArr)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
For i = LBound(vArr) To UBound(vArr)
Set sh = Worksheets(vArr(i))
Set sourceRange = mybook.sh.UsedRange
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.sh.Range("B" & rnum)
' Isolates the store number from the workbook name
getstore = Replace(mybook.Name, "Weekly report sales &
hours_", "")
getstore = Replace(getstore, ".xls", "")
basebook.sh.Cells(rnum, "A").Value = getstore
With sourceRange
Set destrange = basebook.sh.Cells(rnum,
"B").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Next
rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I need to 'consolidate' data into one Master Workbook -- my current
code is below. The data currently sits in approx 30 workbooks and is
spread across a number of worksheets within each WB. All WB are set
up exactly the same way -- same sheet names, etc. The Master WB also
has the same Sheet names (to keep things simple).
My code worked fine when just hitting one worksheet within each WB.
However, when I modified the code to pull from all of the sheets, it
didn't work at all! My modification was to activate the vArr code and
change all references to the single worksheet to use the 'ws'
reference. When I run the code now, the first WB opens and then the
code stops.
What's causing this and how do I fix it?
A couple of other small things aren't working -- there's code to
isolate the store number from the name of each target WB and insert it
into Column A. It should put this store number next to EACH ROW that
is transferred, but it currently just puts it in the first row.
When all data has been pulled from the target WBs, I want all blank
rows to be deleted from each data tab in the Master WB. A blank row
is any row where cells Ax & Bx (where x is row #) are blank.
Any help is greatly appreciated ... here's my current code:
Sub Example2()
Dim MyPath, getstore As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount, x As Long
Dim Fnum, i As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim ws As Worksheet
MyPath =" \\server\folder1\folder2\folder3\"
' the following are sheets within each target WB
vArr = Array("Sales Act", "Hours Act", "Sales LY", "Sales Goal",
"Hours LY", "Hours Goal", "Sales Forecast", "Hours Forecast")
'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 & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets("Hours Act").Cells.Clear
rnum = 2
'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
'Loop through all files in the array(myFiles) and selected sheets
in array(vArr)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
For i = LBound(vArr) To UBound(vArr)
Set sh = Worksheets(vArr(i))
Set sourceRange = mybook.sh.UsedRange
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.sh.Range("B" & rnum)
' Isolates the store number from the workbook name
getstore = Replace(mybook.Name, "Weekly report sales &
hours_", "")
getstore = Replace(getstore, ".xls", "")
basebook.sh.Cells(rnum, "A").Value = getstore
With sourceRange
Set destrange = basebook.sh.Cells(rnum,
"B").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Next
rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub