I am running Office 2003 and I am receiving the error message:
Automation error:
Object invoked has disconnected from its clients
when I try to run the VBA code below. The code repeatedly copies a worksheet that contains 6 charts to individual workbooks, saving each one as it goes. Each workbook is a divisional report containing individual reports for facilities within a specific geographic region. There are about 8 named ranges within the workbook, but none of them reference external files, and none are dynamic.
The code works for the first 20-30 iterations and then gives me the error. On debug it points me to the line containing PasteSpecial, though I can't for the life of me figure out why.
I've searched every Excel resource I know of, read every related thread I can find, and I've read the Microsoft article about unqualified code and early binding numerous times and have tried to fully qualify my code, but nothing so far has worked. Turning to you experts here as my last hope as I've been struggling with this for almost 2 months now.
Another thing that I've noticed is that Microsoft Excel does not release the memory after closing new workbooks. On each iteration Excel eats another 3-10 megs of memory, as measured from the task manager. I think this is probably a different issue, and is less important than the other issue, but I'll throw it out there too in case it helps someone figure out what is going on.
The code:
Sub Generate_Division_FCP_Workbooks()
Application.Calculation = xlCalculationManual
'Application.ScreenUpdating = False
Dim rRow As Range
Dim wbDivisionFCPs As Workbook
Dim wsFCP As Worksheet
'Set wsFCP = Application.Workbooks(1).Worksheets("Report")
Dim rSB As Range
Set rSB = Application.Names("SB").RefersToRange
Dim sTimePeriod As String, sShortTimePeriod As String
sTimePeriod = "December 2009"
sShortTimePeriod = Left(sTimePeriod, 3) & " " & Right(sTimePeriod, 4)
'directories
If Len(Dir("C:\FCPs\" & sTimePeriod & "\Divisions", vbDirectory)) = 0 Then
MkDir ("C:\FCPs\" & sTimePeriod & "\Divisions")
End If
'sort the list
rSB.Sort Key1:=rSB.Cells(1, 8), Order1:=xlAscending, key2:=rSB.Cells(1, 1), order2:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'delete external links
DeleteExternalLinks Application.Workbooks(1)
For Each rRow In rSB.Columns(1).Cells
'add a new workbook unless this is for the same division (group facilities in same division)
If Application.Workbooks.Count < 2 Then
Application.Workbooks.Add
End If
Application.Workbooks(1).Worksheets("Report").Range("FACILITY_ID") = rRow
Application.Calculate
If Not Application.Workbooks(2) Is Nothing Then
'copy worksheet
Application.Workbooks(1).Worksheets("Report").Copy after:=Application.Workbooks(2).Worksheets(Application.Workbooks(2).Worksheets.Count)
'copy and paste values
Application.Workbooks(1).Worksheets("Report").Range("O5:AB113").Copy
Application.Workbooks(2).Worksheets("Report").Range("O5").PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.Workbooks(2).Worksheets("Report").Range("A7").Select
Application.CutCopyMode = False
'change worksheet name
Application.Workbooks(2).Worksheets("Report").Name = Application.Workbooks(2).Worksheets("Report").Range("FACILITY_ID")
End If
'if division changes on next iteration, save and close workbook
If rRow.Offset(0, 7) <> rRow.Offset(1, 7) Then
'delete unused default worksheets
Application.DisplayAlerts = False
Application.Workbooks(2).Worksheets("Sheet1").Delete
Application.Workbooks(2).Worksheets("Sheet2").Delete
Application.Workbooks(2).Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
'delete named ranges
DeleteNamedRanges Application.Workbooks(2)
If Len(Dir("C:\FCPs\" & sTimePeriod & "\Divisions\" & rRow.Offset(0, 5), vbDirectory)) = 0 Then
MkDir ("C:\FCPs\" & sTimePeriod & "\Divisions\" & rRow.Offset(0, 5))
End If
'save and close file
Application.Workbooks(2).SaveAs "C:\FCPs\" & sTimePeriod & "\Divisions\" & rRow.Offset(0, 5) & _
"\" & sShortTimePeriod & " SB - " & Trim(Left(rRow.Offset(0, 7), InStr(1, rRow.Offset(0, 7), " Division"))) & ".xls"
Application.Workbooks(2).Close False
End If
Next rRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done!"
End Sub
Sub DeleteExternalLinks(wb As Workbook)
Dim nm As Name
On Error Resume Next
For Each nm In wb.Names
If (InStr(1, nm.RefersTo, "C:\") Or InStr(1, nm.RefersTo, "#REF")) Then
nm.Delete
End If
Next nm
End Sub
Automation error:
Object invoked has disconnected from its clients
when I try to run the VBA code below. The code repeatedly copies a worksheet that contains 6 charts to individual workbooks, saving each one as it goes. Each workbook is a divisional report containing individual reports for facilities within a specific geographic region. There are about 8 named ranges within the workbook, but none of them reference external files, and none are dynamic.
The code works for the first 20-30 iterations and then gives me the error. On debug it points me to the line containing PasteSpecial, though I can't for the life of me figure out why.
I've searched every Excel resource I know of, read every related thread I can find, and I've read the Microsoft article about unqualified code and early binding numerous times and have tried to fully qualify my code, but nothing so far has worked. Turning to you experts here as my last hope as I've been struggling with this for almost 2 months now.
Another thing that I've noticed is that Microsoft Excel does not release the memory after closing new workbooks. On each iteration Excel eats another 3-10 megs of memory, as measured from the task manager. I think this is probably a different issue, and is less important than the other issue, but I'll throw it out there too in case it helps someone figure out what is going on.
The code:
Sub Generate_Division_FCP_Workbooks()
Application.Calculation = xlCalculationManual
'Application.ScreenUpdating = False
Dim rRow As Range
Dim wbDivisionFCPs As Workbook
Dim wsFCP As Worksheet
'Set wsFCP = Application.Workbooks(1).Worksheets("Report")
Dim rSB As Range
Set rSB = Application.Names("SB").RefersToRange
Dim sTimePeriod As String, sShortTimePeriod As String
sTimePeriod = "December 2009"
sShortTimePeriod = Left(sTimePeriod, 3) & " " & Right(sTimePeriod, 4)
'directories
If Len(Dir("C:\FCPs\" & sTimePeriod & "\Divisions", vbDirectory)) = 0 Then
MkDir ("C:\FCPs\" & sTimePeriod & "\Divisions")
End If
'sort the list
rSB.Sort Key1:=rSB.Cells(1, 8), Order1:=xlAscending, key2:=rSB.Cells(1, 1), order2:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'delete external links
DeleteExternalLinks Application.Workbooks(1)
For Each rRow In rSB.Columns(1).Cells
'add a new workbook unless this is for the same division (group facilities in same division)
If Application.Workbooks.Count < 2 Then
Application.Workbooks.Add
End If
Application.Workbooks(1).Worksheets("Report").Range("FACILITY_ID") = rRow
Application.Calculate
If Not Application.Workbooks(2) Is Nothing Then
'copy worksheet
Application.Workbooks(1).Worksheets("Report").Copy after:=Application.Workbooks(2).Worksheets(Application.Workbooks(2).Worksheets.Count)
'copy and paste values
Application.Workbooks(1).Worksheets("Report").Range("O5:AB113").Copy
Application.Workbooks(2).Worksheets("Report").Range("O5").PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.Workbooks(2).Worksheets("Report").Range("A7").Select
Application.CutCopyMode = False
'change worksheet name
Application.Workbooks(2).Worksheets("Report").Name = Application.Workbooks(2).Worksheets("Report").Range("FACILITY_ID")
End If
'if division changes on next iteration, save and close workbook
If rRow.Offset(0, 7) <> rRow.Offset(1, 7) Then
'delete unused default worksheets
Application.DisplayAlerts = False
Application.Workbooks(2).Worksheets("Sheet1").Delete
Application.Workbooks(2).Worksheets("Sheet2").Delete
Application.Workbooks(2).Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
'delete named ranges
DeleteNamedRanges Application.Workbooks(2)
If Len(Dir("C:\FCPs\" & sTimePeriod & "\Divisions\" & rRow.Offset(0, 5), vbDirectory)) = 0 Then
MkDir ("C:\FCPs\" & sTimePeriod & "\Divisions\" & rRow.Offset(0, 5))
End If
'save and close file
Application.Workbooks(2).SaveAs "C:\FCPs\" & sTimePeriod & "\Divisions\" & rRow.Offset(0, 5) & _
"\" & sShortTimePeriod & " SB - " & Trim(Left(rRow.Offset(0, 7), InStr(1, rRow.Offset(0, 7), " Division"))) & ".xls"
Application.Workbooks(2).Close False
End If
Next rRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done!"
End Sub
Sub DeleteExternalLinks(wb As Workbook)
Dim nm As Name
On Error Resume Next
For Each nm In wb.Names
If (InStr(1, nm.RefersTo, "C:\") Or InStr(1, nm.RefersTo, "#REF")) Then
nm.Delete
End If
Next nm
End Sub
