Workbook Stop Working When Run VBA

GeoKoro13 · #1 11-30-2016, 09:59 PM

Hi guys,

So, I have this huge problem!!!
When I run a vba for deleting all worksheets except 3 specified ones the excel stop working and close. This is a test file so, I don't mind about data but it seems that I can't help it.

There are three main sheets, Master_Sheet,Monthly_Report and Default. As you'll see from the codes below, I use the Default sheet as a template for the sheets I create to enter the data.

So, find below all the coding I use. I'm an amateur with macro so, the coding I use you might find very no-sense.

Code:

Private Sub CommandButton1_Click()Worksheets("Default").Copy After:=Worksheets(Worksheets.Count)
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa


    '~~> Change CountLarge to Count if using xl2003
    If Target.Cells.CountLarge > 1 Then Exit Sub


    Application.EnableEvents = False


    If Not Intersect(Target, Range("B2")) Is Nothing Then
        Select Case Target.Value
        Case Is = "": Rows("6:71").EntireRow.Hidden = True
        Case Else: Rows("6:71").EntireRow.Hidden = False
        End Select
    End If
    
        If Not Intersect(Target, Range("B2")) Is Nothing Then
            Select Case Target.Value
        Case Is = "Mobil": Rows("39:47").EntireRow.Hidden = True


        End Select
    End If
        If Not Intersect(Target, Range("B2")) Is Nothing Then
            Select Case Target.Value
        Case Is = "Mobil": Rows("64:71").EntireRow.Hidden = True
        
        End Select
    End If
        If Not Intersect(Target, Range("B2")) Is Nothing Then
                Select Case Target.Value
        Case Is = "Viva": Rows("33:38").EntireRow.Hidden = True
        
        End Select
    End If
        If Not Intersect(Target, Range("B2")) Is Nothing Then
            Select Case Target.Value
        Case Is = "Viva": Rows("55:63").EntireRow.Hidden = True
        
        End Select
    End If


Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

Code:

Private Sub Worksheet_Change(ByVal Target As Range)If Target.Address = "$E$8" And Range("E8") > 60 Then
Call SummurizeSheets
End If
If Target.Address = "$E$8" And Range("E8") > 300 Then
Call DeleteSheets1
End If
If Target.Address = "$E$8" And Range("E8") > 300 Then
Call CopySheet_End
End If
End Sub

Code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)  If Not Intersect(Target, Range("A2:C14")) Is Nothing Then
    Sh.Name = Sh.Range("B1").Value
  End If
End Sub

Code:

Function sheetname(number As Long) As String    sheetname = Sheets(number).Name
End Function

Code:

Sub DeleteSheets1()    Dim xWs As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each xWs In Application.ActiveWorkbook.Worksheets
        If xWs.Name <> "Master_Sheet" And xWs.Name <> "Monthly_Report" And xWs.Name <> "Default" Then
            xWs.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Code:

Sub SummurizeSheets()    Dim ws As Worksheet
     
    Application.ScreenUpdating = False
    Sheets("Monthly_Report").Activate
     
    For Each ws In Worksheets
        If ws.Name <> "Monthly_Report" And ws.Name <> "Master_Sheet" And ws.Name <> "Default" Then
            ws.Range("B14").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("C14").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 7).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("B2").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("B4").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("D4").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 10).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("E4").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("A9").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("B9").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 13).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("C9").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 14).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("C12").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 15).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("D21").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 16).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("C23").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 17).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("D32").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 18).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("G12").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 19).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("H21").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 20).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("G23").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 21).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            ws.Range("H32").Copy
            Worksheets("Monthly_Report").Cells(Rows.Count, 22).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues


        End If
    Next ws
End Sub

Code:

Sub CopySheet_End()Worksheets("Default").Copy After:=Worksheets(Worksheets.Count)
End Sub

I know it seems to much information but I guess for people like you it will be straight forward to understand.

So, I'm using the Default sheet as template from which I create copies. The default sheet a a ActiveX combo button to create copies of itself. Obviously, its copies have the combo button as well.

When this button exists, if I run the DeleteSheet1 Code I get the Excel Has stopped working... without more information. If you have any idea why the file stop working please let me know.

Thank you!!!

macropod · #2 12-01-2016, 04:03 AM

I don't have time to analyze all your code. However, your SummurizeSheets macro could be made much simpler and more efficient:

Code:

Sub SummarizeSheets()
Application.ScreenUpdating = False
Dim wsSrc As Worksheet, wsTgt As Worksheet, lRow As Long
Set wsTgt = Worksheets("Monthly_Report")
lRow = wsTgt.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
For Each wsSrc In Worksheets
  With wsSrc
    If .Name <> "Monthly_Report" And .Name <> "Master_Sheet" And .Name <> "Default" Then
      wsTgt.Cells(lRow, 6).Value = .Range("B14")
      wsTgt.Cells(lRow, 7).Value = .Range("C14")
      wsTgt.Cells(lRow, 8).Value = .Range("B2")
      wsTgt.Cells(lRow, 9).Value = .Range("B4")
      wsTgt.Cells(lRow, 10).Value = .Range("D4")
      wsTgt.Cells(lRow, 11).Value = .Range("E4")
      wsTgt.Cells(lRow, 12).Value = .Range("A9")
      wsTgt.Cells(lRow, 13).Value = .Range("B9")
      wsTgt.Cells(lRow, 14).Value = .Range("C9")
      wsTgt.Cells(lRow, 15).Value = .Range("C12")
      wsTgt.Cells(lRow, 16).Value = .Range("D21")
      wsTgt.Cells(lRow, 17).Value = .Range("C23")
      wsTgt.Cells(lRow, 18).Value = .Range("D32")
      wsTgt.Cells(lRow, 19).Value = .Range("G12")
      wsTgt.Cells(lRow, 20).Value = .Range("H21")
      wsTgt.Cells(lRow, 21).Value = .Range("G23")
      wsTgt.Cells(lRow, 22).Value = .Range("H32")
    End If
  End With
Next
End Sub

Note how there is no copying/pasting, sheet activation and continual recalculation of the output row.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Excel 2013 hyperlinks stop working	dharris	Excel	0	03-22-2015 05:34 AM
All Office products stop working	lethlean	Office	1	05-18-2013 07:07 AM
Save As cause app to stop working	rafterman	Word	1	03-04-2013 11:20 PM
GIF's stop working	Kwarior	PowerPoint	3	03-17-2010 09:59 PM
Select a range in one one workbook while working in other workbook	Slow&Steady	Excel	1	02-21-2010 03:34 AM