Excel closes all workbooks if certain part of macro is executed???

svendiamond

Well-known Member
Joined
Jun 13, 2014
Messages
1,504
Office Version
  1. 365
Platform
  1. Windows
Hello! I have been successfully running a code for a while now but I just added an extra few lines which does a little bit extra copying and pasting some numbers... for some reason if this part of the code is executed, all my open workbooks are closed! I have Googled this problem and found various answers, to no avail. Do you see anything weird here? The highlighted part is the part that causes the crash (if the user answers "Yes" to the msgbox). And actually, this sub routine is activated through a different sub routine... in which I just have the line "filterthing" to activate this sub, then continue. Also, if I step-through the code, it works just fine. It's only when I run the whole thing that it crashes.

Rich (BB code):
Sub filterThing()


Dim lRow As Long, fRow As Long, loadNumber As Long, cube As Long, saveLoad As VbMsgBoxResult, zRow As Long, xRow As Long
    With Sheets("SUMMARY")
            .Range("J2:K50").ClearContents
            .Range("J2:K50").Borders.LineStyle = xlNone
        lRow = .Range("F" & Rows.Count).End(xlUp).Row
            .Range("F1:F" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Columns("J:J"), Unique:=True
        fRow = .Range("J" & Rows.Count).End(xlUp).Row
            .Range("K2").Value = "=COUNTIF(F:F,J2)/(COUNTA(F:F)-1)"
            .Range("K2:K" & fRow).Select
                Selection.FillDown
            .Range("J2:K" & fRow).Borders.LineStyle = xlContinuous
                
                'sort
                .Range("K2").Select
                ActiveWorkbook.Worksheets("SUMMARY").Sort.SortFields.Clear
                ActiveWorkbook.Worksheets("SUMMARY").Sort.SortFields.Add Key:=Range("K2"), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                        With ActiveWorkbook.Worksheets("SUMMARY").Sort
                            .SetRange Range("J1:K" & fRow)
                            .Header = xlGuess
                            .MatchCase = False
                            .Orientation = xlTopToBottom
                            .SortMethod = xlPinYin
                            .Apply
                        End With
    End With
    
saveLoad = MsgBox("Save this load?", vbYesNo)
    If saveLoad = vbYes Then
        loadNumber = InputBox("Load number?")
        cube = InputBox("Cube?")
        zRow = Sheets("TRENDS").Range("C" & Rows.Count).End(xlUp).Row + 1
            Sheets("SUMMARY").Range("J2:K" & fRow).Copy
                With Sheets("TRENDS")
                    .Activate
                    .Range("C" & zRow).PasteSpecial xlPasteValues
                    .Range("A" & zRow).Value = loadNumber
                    .Range("B" & zRow).Value = cube
                         xRow = .Range("C" & Rows.Count).End(xlUp).Row
                                .Range("A" & zRow & ":B" & xRow).Select
                                    Selection.FillDown
                                .Range("A" & zRow & ":D" & xRow).Borders.LineStyle = xlContinuous
                    .Range("A1").Select
                End With
    End If
End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Hi,
no thoughts on why your code should crash in such dramatic fashion but see if this updated code makes any difference.

Code:
Sub filterThing()
    Dim saveload As Integer, i As Integer
    Dim xRow As Long, zRow As Long
    Dim lRow As Long, fRow As Long
    Dim Prompt As Variant, GetInput(2) As Variant
    
    
    With Sheets("SUMMARY")
            .Range("J2:K50").ClearContents
            .Range("J2:K50").Borders.LineStyle = xlNone
        lRow = .Range("F" & Rows.Count).End(xlUp).Row
            .Range("F1:F" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Columns("J:J"), Unique:=True
        fRow = .Range("J" & Rows.Count).End(xlUp).Row
            .Range("K2").Value = "=COUNTIF(F:F,J2)/(COUNTA(F:F)-1)"
            .Range("K2:K" & fRow).FillDown
            .Range("J2:K" & fRow).Borders.LineStyle = xlContinuous
                
                'sort
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("K2"), _
                    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                        With ActiveWorkbook.Worksheets("SUMMARY").Sort
                            .SetRange Range("J1:K" & fRow)
                            .Header = xlGuess
                            .MatchCase = False
                            .Orientation = xlTopToBottom
                            .SortMethod = xlPinYin
                            .Apply
                        End With
    End With
    
    
    saveload = MsgBox("Save this load?", 36, "Save Load")
    
    If saveload = vbYes Then
    Prompt = Array("Load Number", "Cube")
    i = LBound(Prompt)
    
    Do
        GetInput(i) = InputBox("Enter " & Prompt(i), Prompt(i))
        'cancel pressed
        If StrPtr(GetInput(i)) = 0 Then Exit Sub
        'numeric only
        If IsNumeric(GetInput(i)) Then i = i + 1
    Loop Until i > UBound(Prompt)
        
            Sheets("SUMMARY").Range("J2:K" & fRow).Copy
            
                With Sheets("TRENDS")
                zRow = .Range("C" & .Rows.Count).End(xlUp).Row + 1
                    .Range("C" & zRow).PasteSpecial xlPasteValues
                    .Range("A" & zRow).Value = CLng(GetInput(LBound(Prompt)))
                    .Range("B" & zRow).Value = CLng(GetInput(UBound(Prompt)))
             xRow = .Range("C" & Rows.Count).End(xlUp).Row
                    .Range("A" & zRow & ":B" & xRow).FillDown
                    .Range("A" & zRow & ":D" & xRow).Borders.LineStyle = xlContinuous
                End With
    End If
End Sub

Dave
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,106
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top