Night_Rain
Board Regular
- Joined
- Jan 1, 2005
- Messages
- 181
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?
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?
Code:
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