Excel crashing with macro execution

[Night_Rain]

I've designed a tool to present information on lead times for different materials. I have a hidden sheet with all the historical delivery information over the last 12 completed calendar months, and a user enters the code for a particular material, and gets information back on what suppliers have provided the material, average delivery times, and an assortment of other stuff.

Unfortunately, executing the code crashes Excel any time it is run with a material that has only one line, and I can't figure out why. If I run through the code line by line, nothing happens, and all seems well. But if I let the macro rip along at normal speed, Excel just dissapears.

Here is the offending code. I've noticed that if I put a breakpoint on the line in all caps (RANGE("B11")=CNTRCTNUM... near the middle), and then resume, Excel does not crash, and the macro runs fine. A break before that, and the macro runs fine, but then Excel crashes on resumption, and with a break after, Excel crashes before getting to the break. Can anyone ID what is wrong, or suggest a workaround?

Sub NewMID()
    Dim i As Long, FinalRow As Long, LastClm As Integer
    Dim MIDcode As Variant
    Dim x(1 To 31) As Variant
    Dim MIDrow As Long, WrtRow As Integer
    Dim NumOrders As Integer, VenCount As Integer
    Dim VenName As String, VenNum As String
    Dim LeadTime As Long, CntrctNum As String
    Dim ErrorResponse As Integer
        
    Application.ScreenUpdating = False
    With Range("D7:J14")
        .ClearContents
        .ClearFormats
    End With
    Rows("22:65536").EntireRow.Hidden = False
    Columns("D:J").EntireColumn.AutoFit
    Sheets("MID Search").Range("B23", "B65536").EntireRow.ClearContents
    With Sheets("Raw Data")
        .Visible = True
        .Activate
    End With
    Range("A3").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlYes
'   Get MID value to search.  Set up error handling to handle cases where user selects an MID not
'   in the data, or enters something other than a number.
    On Error Resume Next
    MIDcode = InputBox("Please enter MID code:", "MID search")
    If MIDcode = "" Then GoTo AbortCode  ' exit sub if cancel button clicked
    If Err <> 0 Then
        On Error GoTo 0
        MIDcode = InputBox("You entered " & MIDcode & ".  Please enter numeric values only." _
            & vbNewLine & "Enter MID code:", "MID search")
        If MIDcode = "" Then GoTo AbortCode
    End If
    Range("A1").Select
    On Error Resume Next
    Range("A:A").Find(MIDcode, LookAt:=xlWhole).Activate
    If Err <> 0 Then
        On Error GoTo 0
        Do
            ErrorResponse = MsgBox("The MID you entered, " & MIDcode & ", was not found.  " _
                & "Try again?", vbYesNo)
            If ErrorResponse = vbNo Then GoTo AbortCode
            On Error Resume Next
            MIDcode = InputBox("Please enter MID code:", "MID search")
            If MIDcode = "" Then GoTo AbortCode
            Range("A:A").Find(MIDcode, LookAt:=xlWhole).Activate
        Loop While Err <> 0
    End If
'   resume normal error handling
    On Error GoTo 0
'   write MID data to "MID Search" sheet
    MIDrow = ActiveCell.Row
    WrtRow = 23
    Do
        For i = 1 To 31
            x(i) = Cells(MIDrow, i)
        Next 'i
        For i = 3 To 31
            Sheets("MID Search").Cells(WrtRow, i - 2) = x(i)
        Next 'i
        WrtRow = WrtRow + 1
        MIDrow = MIDrow + 1
    Loop While Cells(MIDrow, 1) = Val(MIDcode)
    Sheets("Raw Data").Visible = False
    FinalRow = Sheets("MID Search").Range("B65536").End(xlUp).Row
    Range("AC23", Cells(FinalRow, 29)).NumberFormat = "#.0000"
'   MID
    Range("B4") = MIDcode
'   Description
    Range("B5") = x(2)
'   Specification number
    If WorksheetFunction.IsNumber(x(31)) Then
        If x(31) > 1 Then
            With Range("B6")
                .Value = x(31)
                .NumberFormat = "#.0000"
            End With
        Else
            Range("B6") = "none"
        End If
    Else
        Range("B6") = "none"
    End If
'   Supplier Names
    VenName = WorksheetFunction.Proper(Range("B23"))
    VenCount = 1
    If FinalRow > 23 Then
        For i = 24 To FinalRow
            If Cells(i, 17) <> Cells(i - 1, 17) Then
                VenName = VenName & vbNewLine & WorksheetFunction.Proper(Cells(i, 2))
                VenCount = VenCount + 1
            End If
        Next 'i
    End If
    Range("B7") = VenName
'   Vendor numbers
    VenNum = Range("Q23")
    If FinalRow > 23 Then
        For i = 24 To FinalRow
            If Cells(i, 17) <> Cells(i - 1, 17) Then VenNum = VenNum & vbNewLine & Cells(i, 17)
        Next 'i
    End If
    Range("B8") = VenNum
'   # of orders
    Range("E23").Sort Key1:=Range("E23"), Header:=xlYes
    NumOrders = 0
    For i = 23 To FinalRow
        If Cells(i, 5) <> Cells(i - 1, 5) Then NumOrders = NumOrders + 1
    Next 'i
    Range("B9") = NumOrders
'   # of shipments
    Range("B10") = FinalRow - 22
'   Contracts
    Range("D23").Sort Key1:=Range("D23"), Header:=xlYes
    CntrctNum = ""
    If Range("D23") <> "" Then CntrctNum = Range("D23")
    If FinalRow > 23 Then
        For i = 24 To FinalRow
            If Cells(i, 4) <> Cells(i - 1, 4) And Cells(i, 4) <> "" _
                Then CntrctNum = CntrctNum & vbNewLine & Cells(i, 4)
        Next 'i
    End If
    RANGE("B11")=CNTRCTNUM
'   average days to deliver
    Range("AD23").FormulaR1C1 = "=RC[-15]-RC[-20]"
    If FinalRow > 23 Then
        Range("AD23", Cells(FinalRow, 30)).FillDown
    End If
    LeadTime = 0
    For i = 23 To FinalRow
        LeadTime = LeadTime + Cells(i, 30)
    Next 'i
    With Range("B12")
        .Value = LeadTime / (FinalRow - 22)
        .NumberFormat = "#.0"
    End With
'   longest delivery
    Range("B13") = WorksheetFunction.Max(Range("AD23", Cells(FinalRow, 30)))
'   shortest delivery
    Range("B14") = WorksheetFunction.Min(Range("AD23", Cells(FinalRow, 30)))
'   date last ordered
    Range("J23").Sort Key1:=Range("J23"), Order1:=xlDescending, Header:=xlYes
    With Range("B15")
        .Value = Range("J23")
        .NumberFormat = "mmmm d, yyyy"
    End With
'   supplier
    Range("B16") = WorksheetFunction.Proper(Range("B23"))
'   days to deliver
    Range("B17") = Range("AD23")
'   Buyer
    Range("B18") = Range("Y23")
'   Material Planner
    If WorksheetFunction.IsError(Range("Z23")) Then
        Range("B19") = "no Planner listed"
    Else
        Range("B19") = Range("Z23")
    End If
'   Standards Engineer
    If WorksheetFunction.IsError(Range("AB23")) Then
        Range("B20") = "no Engineer listed"
    Else
        Range("B20") = WorksheetFunction.Proper(Range("AB23"))
    End If
'   Multi-vendor information
    With Range("D7:J14")
        .ClearContents
        .ClearFormats
    End With
    If VenCount > 1 Then
        Call Multiple_Vendors
    Else
        With Sheets("MID Search").PageSetup
            .PrintArea = "$A$1:$B$20"
            .Orientation = xlPortrait
            .PaperSize = xlPaperLetter
        End With
    End If
    Rows("22:" & FinalRow).EntireRow.Hidden = True
    Cells.VerticalAlignment = xlTop
    Exit Sub
AbortCode:
    Sheets("Raw Data").Visible = False
    With Sheets("MID Search")
        .Range("B4:B20").ClearContents
        .Range("B23:B65336").EntireRow.Delete
        .Rows("22").EntireRow.Hidden = True
        With Range("D7:J14")
            .ClearContents
            .ClearFormats
        End With
    End With
End Sub

 

[ac_crusade]

Maybe from this...

If Range("D23") <> "" Then CntrctNum = Range("D23") 
    If FinalRow > 23 Then 
        For i = 24 To FinalRow 
            If Cells(i, 4) <> Cells(i - 1, 4) And Cells(i, 4) <> "" _ 
                Then CntrctNum = CntrctNum & vbNewLine & Cells(i, 4) 
        Next 'i 
    End If 
    RANGE("B11")=CNTRCTNUM

To This

If FinalRow > 23 Then 
        For i = 24 To FinalRow 
            If Cells(i, 4) <> Cells(i - 1, 4) And Cells(i, 4) <> "" _ 
                Then CntrctNum = CntrctNum & vbNewLine & Cells(i, 4) 
        Next 'i
    else
            If Range("D23") <> "" Then CntrctNum = Range("D23") 
    End If 
RANGE("B11")=CNTRCTNUM

Untested, Don't know if that will work.

 

[Night_Rain]

Thank you for the try... I think the way you coded that flows better and is easier to read... but Excel still crashes.

 

[NdNoviceHlp]

Maybe try controlling your calculation event. Perhaps XL doesn't have some value it needs and just buggers off looking for it. Maybe it's worth a try. Dave
edit: spelling I hates it
Start...

Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual

End...

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True