Spreadsheet Frequently Crashes on Close

[Shiremaid]

It saves just fine, but then crashes.

Details: Multi tab (approx 35) tab workbook (workbook size 3700kb) with some fairly basic macros (none of which trigger at close or seem to cause any other problems)

It doesn't matter whether I hit save separately and then close, or if I hit close, say yes to saving, and then it closes, both can result in it crashing and re-opening. All my changes are always still there because the save does work in both situations.
It doesn't happen every time, and it seems to be more likely the longer I've had the workbook open.

So, do I possibly have a corruption somewhere? Or is there something to do with the size? Or something else?

Anyone have any ideas?
Cause I've done a couple of rebuilds and the problem keeps coming back.

 

[hiker95]

Shiremaid,

In order to assist you it would help us if you posted all of your macro code using code tags.

When posting VBA code, please use Code Tags - like this:

[code=rich]

'Paste your code here.

[/code]

 

[Shiremaid]

Here are the codes in my workbook. Forgive (and critique if you like) the messiness, I'm a little rusty and google search taught.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Value = "Double-Click to Add An Action" Then
    ActiveCell.Offset(2, 0).Rows("1:1").EntireRow.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    ActiveCell.Range("A1:F1").Select
    Selection.ClearContents
    ActiveCell.Select
    ElseIf Target.Value = "Double-Click to Add an Amendment" Then
    ActiveCell.Rows("1:3").EntireRow.Select
    Selection.Copy
    ActiveCell.Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "Amendment"
    ActiveCell.Offset(0, 4).Range("A1").Select
    Selection.ClearContents
    ActiveCell.FormulaR1C1 = "HHS #"
    ActiveCell.Offset(0, -4).Range("A1").Select
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    ActiveCell.Offset(2, 0).Range("A1:E1").Select
    Selection.ClearContents
    End If
End Sub

Sub UnprotectAllSheets()


Dim ws As Worksheet
Dim strPwd As String
Dim strCheck As String


strCheck = "fakepassword"
strPwd = InputBox("Enter Password", "Password", "Enter Password")


ActiveWorkbook.Unprotect Password:=strPwd


If strPwd = strCheck Then
  For Each ws In ThisWorkbook.Worksheets
    ws.Unprotect Password:=strPwd
  Next ws


Sheets("REPORTS").Select
ActiveSheet.Shapes.Range(Array("Finished Updating")).Visible = True


Range("D1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"


Else
  MsgBox "Incorrect Password"
End If


End Sub

Sub ProtectSheets()


Range("D1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Dim ws As Worksheet
Dim pwd As String


pwd = "fakepassword"
For Each ws In Worksheets
    ws.Protect Password:=pwd, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True


Next ws


ActiveWorkbook.Protect Password:=pwd


Sheets("REPORTS").Select
ActiveSheet.Shapes.Range(Array("Finished Updating")).Visible = False


End Sub

Sub SiteReport()
    If Range("Site_Report").EntireRow.Hidden = True Then
        Range("Site_Report").EntireRow.Hidden = False
    Else
        Range("Site_Report").EntireRow.Hidden = True
    End If
End Sub

 

[hiker95]

Shiremaid,

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

In your following Worksheet_BeforeDoubleClick code modules, try adding the last BOLD line, and, test it.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Value = "Double-Click to Add An Action" Then
    ActiveCell.Offset(2, 0).Rows("1:1").EntireRow.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    ActiveCell.Range("A1:F1").Select
    Selection.ClearContents
    ActiveCell.Select
    ElseIf Target.Value = "Double-Click to Add an Amendment" Then
    ActiveCell.Rows("1:3").EntireRow.Select
    Selection.Copy
    ActiveCell.Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "Amendment"
    ActiveCell.Offset(0, 4).Range("A1").Select
    Selection.ClearContents
    ActiveCell.FormulaR1C1 = "HHS #"
    ActiveCell.Offset(0, -4).Range("A1").Select
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    ActiveCell.Offset(2, 0).Range("A1:E1").Select
    Selection.ClearContents
    End If

    Application.CutCopyMode = False

End Sub

 

[Shiremaid]

Unfortunately, it doesn't seem to have worked.

 

[hiker95]

Shiremaid,

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.

 

[Shiremaid]

Bump

 

[hiker95]

Unfortunately, it doesn't seem to have worked.

Shiremaid.

Did you put the additional line of code:

Application.CutCopyMode = False

In each of the Worksheet_BeforeDoubleClick events, before the End Sub?