Excel 97 Memory error. Explain?

[iforbes]

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&quot
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&quot).Select
Worksheets("COO&quot.Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Application.DisplayAlerts = True
Worksheets("Total All CBU's&quot.Select

CleanUp

Range("a1&quot.Select
Worksheets("Small CBU&quot.Select

CleanUp

Range("a1&quot.Select
Worksheets("Major&quot.Activate

CleanUp

Range("a1&quot.Select
Worksheets("Public Sector&quot.Activate

CleanUp

Range("a1&quot.Select
Worksheets("Government
Programs&quot.Select

CleanUp

Range("a1&quot.Select
Worksheets("New York&quot.Select

CleanUp

Range("a1&quot.Select
Worksheets(Array("Total All
CBU's", "Small CBU", "Major", "Public Sector" _
, "Government Programs", "New
York&quot).Select
Worksheets("Total All CBU's&quot.Activate
Columns("A:L&quot.Select
Range("K1&quot.Activate
Application.CutCopyMode = False
Selection.Delete shift:=xlToLeft
Worksheets("COO&quot.Select
Application.DisplayAlerts = False
Worksheets(Array("Work
Menu", "Budget", "Hospital", "MedSurg", _
"RX_Dental", "CompleteTable", "tblSumma
ry", "National", "Medicaid&FEP", "dATAbASE&quot).Delete
End If

Workbooks(strNewCopyName).Activate
Worksheets("coo&quot.Select
Range("A1:AD1&quot.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&quot).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&quot.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&quot.Select
Range("A1&quot.Select
Worksheets("Government Programs&quot.Select
Range("A1&quot.Select
Worksheets("Major&quot.Select
Range("A1&quot.Select
Worksheets("New York&quot.Select
Range("A1&quot.Select
Worksheets("Public Sector&quot.Select
Range("A1&quot.Select
Worksheets("Small CBU&quot.Select
Range("A1&quot.Select
Worksheets("COO&quot.Select
Range("A1&quot.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&quot.Select
Range("A1&quot.Select
Worksheets("COO&quot.Select
Range("A1&quot.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

 

[mlee1]

Hi

We get that regular running NT and Office 97. The problem is almost always a corrupt user profile on the machine. Try removing and recreating the users profile and that should sort it for you.

Rgds
Martin