Pentium 4 512meg memory
NT 4.0 Service Pack 6a
Excel 97 SR-2
I run the following code in Excel that takes a workbook
with multiple worksheets and saves the needed worksheets
as read only and eliminates unneeded worksheets.
The problem is with the newly created workbooks. When I
open the newely created workbooks i get the following
error:
"The instruction at "0x3046ff43" referenced memory
at "0x00000018". The memory could not be "written".
This happens with both newly created workbooks.
Any suggestions???
Thanks!
Ian
Option Explicit
Dim strNewCopy As String
Dim strNewCopyName As String
Dim Err1 As Integer
Static Sub DistributionCopy()
Dim strAnswer As String
strNewCopyName = ActiveWorkbook.Name
strAnswer = MsgBox("Continuing this action will
automatically save and close this workbook." & Chr(13) &
Chr(13) & " Would you like to
continue?", vbYesNo + vbExclamation, "Warning"
If strAnswer = vbNo Then
Exit Sub
Else
Application.StatusBar = "Creating the
distribution copies. Please wait...."
ActiveWorkbook.Save
ActiveWorkbook.SaveCopyAs Filename:= _
"h:\data\actuary\stats\memtqm02\backup\Copyof"
& ActiveWorkbook.Name ', FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = False
Worksheets(Array
("COO", "Graphs", "Total All CBU's", "Government
Programs", "Major", "New York", _
"Public Sector", "Small CBU").Select
Worksheets("COO".Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Application.DisplayAlerts = True
Worksheets("Total All CBU's".Select
CleanUp
Range("a1".Select
Worksheets("Small CBU".Select
CleanUp
Range("a1".Select
Worksheets("Major".Activate
CleanUp
Range("a1".Select
Worksheets("Public Sector".Activate
CleanUp
Range("a1".Select
Worksheets("Government
Programs".Select
CleanUp
Range("a1".Select
Worksheets("New York".Select
CleanUp
Range("a1".Select
Worksheets(Array("Total All
CBU's", "Small CBU", "Major", "Public Sector" _
, "Government Programs", "New
York").Select
Worksheets("Total All CBU's".Activate
Columns("A:L".Select
Range("K1".Activate
Application.CutCopyMode = False
Selection.Delete shift:=xlToLeft
Worksheets("COO".Select
Application.DisplayAlerts = False
Worksheets(Array("Work
Menu", "Budget", "Hospital", "MedSurg", _
"RX_Dental", "CompleteTable", "tblSumma
ry", "National", "Medicaid&FEP", "dATAbASE").Delete
End If
Workbooks(strNewCopyName).Activate
Worksheets("coo".Select
Range("A1:AD1".Select
Call SaveNewCopy
If Err1 = "1" Then
Exit Sub
End If
Application.StatusBar = False
Application.DisplayAlerts = False
Worksheets(Array("Total All CBU's", "Small
CBU", "Major", "Public Sector", "Government
Programs", "New York").Delete
Application.DisplayAlerts = True
Call SaveCOOCopy
If Err1 = "2" Then
Exit Sub
End If
Application.DisplayAlerts = False
MsgBox "The following two distribution copies have
been saved in" & Chr(10) & "
H:\Data\Actuary\Stats\Memtqm02\COO Membership\:" & Chr(10)
& Chr(10) & " " & UCase(Left
(strNewCopyName, 1)) & LCase(Mid(strNewCopyName, 2, 2))
& "Membership.xls" & Chr(10) & Chr(10)
& " " & UCase(Left
(strNewCopyName, 1)) & LCase(Mid(strNewCopyName, 2, 2))
& "COOFinal.xls.", , "Save Successful"
Application.DisplayAlerts = True
CleanModule
End Sub
Sub CleanUp()
Application.ScreenUpdating = False
Range("L8".Activate
Do Until IsEmpty(ActiveCell.Value) = True
If ActiveCell.Value = 1 Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1).Activate
End If
Loop
End Sub
Static Sub SaveNewCopy()
On Error GoTo ErrorMessage
'Application.StatusBar = False
Application.ScreenUpdating = True
Worksheets("Total All CBU's".Select
Range("A1".Select
Worksheets("Government Programs".Select
Range("A1".Select
Worksheets("Major".Select
Range("A1".Select
Worksheets("New York".Select
Range("A1".Select
Worksheets("Public Sector".Select
Range("A1".Select
Worksheets("Small CBU".Select
Range("A1".Select
Worksheets("COO".Select
Range("A1".Select
Application.ScreenUpdating = False
Application.DisplayAlerts = True
ActiveWorkbook.SaveCopyAs Filename:= _
"h:\data\actuary\stats\memtqm02\coo membership\" &
UCase(Left(strNewCopyName, 1)) & LCase(Mid(strNewCopyName,
2, 2)) & "Membership.xls"
Exit Sub
ErrorMessage:
MsgBox "Please do not save over a previously saved
file. Either delete the old file or rename the file and
try again.", , "Error"
Application.StatusBar = False
Err1 = 1
End Sub
Static Sub SaveCOOCopy()
On Error GoTo ErrorMessage
Application.ScreenUpdating = True
Worksheets("Graphs".Select
Range("A1".Select
Worksheets("COO".Select
Range("A1".Select
ActiveWorkbook.SaveAs Filename:= _
"H:\DATA\ACTUARY\STATS\Memtqm02\COO Membership\" &
UCase(Left(strNewCopyName, 1)) & LCase(Mid(strNewCopyName,
2, 2)) & "CooFinal.xls"
Application.ScreenUpdating = False
Exit Sub
ErrorMessage:
MsgBox "Please do not save over a previously saved
file. Either delete the old file or rename the file and
try again.", , "Error"
Application.StatusBar = False
Err1 = 2
End Sub
NT 4.0 Service Pack 6a
Excel 97 SR-2
I run the following code in Excel that takes a workbook
with multiple worksheets and saves the needed worksheets
as read only and eliminates unneeded worksheets.
The problem is with the newly created workbooks. When I
open the newely created workbooks i get the following
error:
"The instruction at "0x3046ff43" referenced memory
at "0x00000018". The memory could not be "written".
This happens with both newly created workbooks.
Any suggestions???
Thanks!
Ian
Option Explicit
Dim strNewCopy As String
Dim strNewCopyName As String
Dim Err1 As Integer
Static Sub DistributionCopy()
Dim strAnswer As String
strNewCopyName = ActiveWorkbook.Name
strAnswer = MsgBox("Continuing this action will
automatically save and close this workbook." & Chr(13) &
Chr(13) & " Would you like to
continue?", vbYesNo + vbExclamation, "Warning"
If strAnswer = vbNo Then
Exit Sub
Else
Application.StatusBar = "Creating the
distribution copies. Please wait...."
ActiveWorkbook.Save
ActiveWorkbook.SaveCopyAs Filename:= _
"h:\data\actuary\stats\memtqm02\backup\Copyof"
& ActiveWorkbook.Name ', FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = False
Worksheets(Array
("COO", "Graphs", "Total All CBU's", "Government
Programs", "Major", "New York", _
"Public Sector", "Small CBU").Select
Worksheets("COO".Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Application.DisplayAlerts = True
Worksheets("Total All CBU's".Select
CleanUp
Range("a1".Select
Worksheets("Small CBU".Select
CleanUp
Range("a1".Select
Worksheets("Major".Activate
CleanUp
Range("a1".Select
Worksheets("Public Sector".Activate
CleanUp
Range("a1".Select
Worksheets("Government
Programs".Select
CleanUp
Range("a1".Select
Worksheets("New York".Select
CleanUp
Range("a1".Select
Worksheets(Array("Total All
CBU's", "Small CBU", "Major", "Public Sector" _
, "Government Programs", "New
York").Select
Worksheets("Total All CBU's".Activate
Columns("A:L".Select
Range("K1".Activate
Application.CutCopyMode = False
Selection.Delete shift:=xlToLeft
Worksheets("COO".Select
Application.DisplayAlerts = False
Worksheets(Array("Work
Menu", "Budget", "Hospital", "MedSurg", _
"RX_Dental", "CompleteTable", "tblSumma
ry", "National", "Medicaid&FEP", "dATAbASE").Delete
End If
Workbooks(strNewCopyName).Activate
Worksheets("coo".Select
Range("A1:AD1".Select
Call SaveNewCopy
If Err1 = "1" Then
Exit Sub
End If
Application.StatusBar = False
Application.DisplayAlerts = False
Worksheets(Array("Total All CBU's", "Small
CBU", "Major", "Public Sector", "Government
Programs", "New York").Delete
Application.DisplayAlerts = True
Call SaveCOOCopy
If Err1 = "2" Then
Exit Sub
End If
Application.DisplayAlerts = False
MsgBox "The following two distribution copies have
been saved in" & Chr(10) & "
H:\Data\Actuary\Stats\Memtqm02\COO Membership\:" & Chr(10)
& Chr(10) & " " & UCase(Left
(strNewCopyName, 1)) & LCase(Mid(strNewCopyName, 2, 2))
& "Membership.xls" & Chr(10) & Chr(10)
& " " & UCase(Left
(strNewCopyName, 1)) & LCase(Mid(strNewCopyName, 2, 2))
& "COOFinal.xls.", , "Save Successful"
Application.DisplayAlerts = True
CleanModule
End Sub
Sub CleanUp()
Application.ScreenUpdating = False
Range("L8".Activate
Do Until IsEmpty(ActiveCell.Value) = True
If ActiveCell.Value = 1 Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1).Activate
End If
Loop
End Sub
Static Sub SaveNewCopy()
On Error GoTo ErrorMessage
'Application.StatusBar = False
Application.ScreenUpdating = True
Worksheets("Total All CBU's".Select
Range("A1".Select
Worksheets("Government Programs".Select
Range("A1".Select
Worksheets("Major".Select
Range("A1".Select
Worksheets("New York".Select
Range("A1".Select
Worksheets("Public Sector".Select
Range("A1".Select
Worksheets("Small CBU".Select
Range("A1".Select
Worksheets("COO".Select
Range("A1".Select
Application.ScreenUpdating = False
Application.DisplayAlerts = True
ActiveWorkbook.SaveCopyAs Filename:= _
"h:\data\actuary\stats\memtqm02\coo membership\" &
UCase(Left(strNewCopyName, 1)) & LCase(Mid(strNewCopyName,
2, 2)) & "Membership.xls"
Exit Sub
ErrorMessage:
MsgBox "Please do not save over a previously saved
file. Either delete the old file or rename the file and
try again.", , "Error"
Application.StatusBar = False
Err1 = 1
End Sub
Static Sub SaveCOOCopy()
On Error GoTo ErrorMessage
Application.ScreenUpdating = True
Worksheets("Graphs".Select
Range("A1".Select
Worksheets("COO".Select
Range("A1".Select
ActiveWorkbook.SaveAs Filename:= _
"H:\DATA\ACTUARY\STATS\Memtqm02\COO Membership\" &
UCase(Left(strNewCopyName, 1)) & LCase(Mid(strNewCopyName,
2, 2)) & "CooFinal.xls"
Application.ScreenUpdating = False
Exit Sub
ErrorMessage:
MsgBox "Please do not save over a previously saved
file. Either delete the old file or rename the file and
try again.", , "Error"
Application.StatusBar = False
Err1 = 2
End Sub