Windows XP vba code help

A

alyce

Joined
Jan 7, 2012
Messages
6
Reaction score
0
can anybody advise how i amend this code to refresh an existing workbook instead of opening a new workbook each time the macro is run?

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\Ron\test"
' 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
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("A1:C1")
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("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
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
 
Alyce,

I am not sure the goal of the macro.

These are the lines in your code that create the new workbook:
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1


This is the command to refresh a workbook:
ActiveWorkbook.RefreshAll

A little background on what you are trying to achieve with the macro may help understand where to put the refresh statement.

Stoneboysteve
 
Hi Stoneboysteve

I am trying to collect data from more than one workbook into one "master" workbook. This is a procedure that will be run quite regularly, and it needs to update the master workbook each time instead of open a new one - there will be pivots and reports run off of this master summary page.

I have this code and it is perfect, except for the opening new workbooks thing.
But when I change the code the you have suggested, I get an error message that says Run-time error '91': Object variable or With block variable not set
Then when I click on debug, it highlights this piece of code: BaseWks.Columns.AutoFit_

I am really stumped with this
I really hope you can help

Here is the full code as it is at the moment:
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:\Documents and Settings\MARGARET\Desktop\test the macro"
' 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.
ActiveWorkbook.RefreshAll
' 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 = .UsedRange
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("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
ExitTheSub:
' Restore the application properties.
With Application_
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
 
Alyce,

Sorry I was not more clear, I did not intend to literally replace the code to create a new workbook with the code to refresh. I was merely pointing out the line of code that created the new workbook and the command that would refresh. Since BaseWks is the name of the new workbook, any following commands will fail unless it is available.

I made some comments in line on the original code you posted (without the changes regarding the refresh) below to try to make some sense of the workflow. I made some assumptions as I do not have the files or configuration to test.

Please look at the comment I made on this line of code:
Set sourceRange = .Range("A1:C1")

I suspect extending the range will show you the data you are missing, but again am not clear on your exact problem. Hope it helps.

Stoneboysteve


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.

'''This path should lead to a folder containing one or more Excel files. The next lines of code modify the MyPath name so it can be resolved.
MyPath = "C:\Users\Ron\test"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'''The following checks for files with xl extensions. The "*" should allow for xls, xlsx, etc
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
'''I suggest putting a msgbox here to see if files are found.
msgbox FilesInPath
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'''Fnum is a variable to count the files. It is incremented by the do while loop
' 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

'''The original user may have had some issues, these lines of code are configuration. If you continue to get bugs you may comment them out
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'''this creates the new workbook. I tested it, it works fine.
' 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
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(1)


'''this may be what is missing from your request. I changed it in my test, extending the range will bring in more data. The first column is the name of the source file.
Set sourceRange = .Range("A1:C1")
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("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
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
 
Hi Stoneboysteve,

Thank you for your effort to date - I will seriously appreciate it if you coudl help me get this figured out.
I am working with fake data at present just to get this code cracked.
I have 3 basic excel sheets saved in a folder with fake data - I have treid to attach them to this site, but am not having any luck.
Then in a different folder I have a summary sheet that has this macro embedded into it.
It is working almost perfectly ...

The only thing that I would like to be different:

I do not want a new summary sheet every time I run the macro

I would like the data to refresh the same summary sheet every time.

Imagine that there are 3 sales people each filling in a document. The doc has the same number of columns, with the same headings in each column.
Then imagine that the manager wants to roll up once a month from each sales person's workbook.
The data should be collected from cell A2 and it should collect all data beyond this point (just not row 1 as that is where the headings are). The number of rows will vary from person to person and from month to month.

Se we need to change this instruction so that it does not open a new workbook - how do we tell it to refresh the existing workbook?

'''this creates the new workbook. I tested it, it works fine.
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
 
Hi Alyce,

I tested this, it works to open the workbook from my file location.

Code sections:
'add these to the declaration section
Dim oExcel As Excel.Application
Dim oBook As Workbook

'Add these lines of code, customize the file location and sheet name:
Set oExcel = New Excel.Application
oExcel.Visible = True

Set oBook = oExcel.Workbooks.Open("c:\users\steve\test\tester.xlsx")
Sheets("sheet1").Activate

Stoneboysteve
 
Could you show me what the full code looks like? I don't what to put where / what to take out etc
 
Alyce,

I tested this and it appears to work. You need to create the workbook you want to update, set the path for the folder search, enter the location in MyFilePath, and the range to select from each workbook.

I did not test to see if it writes over each time. You said you use pivot tables, you will need to refresh them to the new ranges.

Please let us know how it works out, or let me know if you have any problems with the code.

Stoneboysteve


Sub combineandmerge011012pcreview()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim oBook As Workbook
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim MyFilePath As String

' Change this to the path\folder location of your files.
MyPath = "c:\users\steve\test"
MyFilePath = "c:\users\steve\test\tteerrtt\tester.xlsx"

' 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 oexcel = New Excel.Application
oexcel.Visible = True
Set oBook = oexcel.Workbooks.Open(MyFilePath)
Set BaseWks = oBook.Worksheets("Sheet1")
BaseWks.Activate
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("A1:d10")
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("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
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
 
Got it sorted at last - thanks for your help so far!

replaced the code below with (didn't change the comment) :

' Add a new workbook with one sheet.
Set BaseWks = ActiveWorkbook.Worksheets(1)
rnum = 1
 
have also ordered "VBA for Dummies" - can see I am going to be learning a new language...
 
Back
Top