XL2000: Creating scenario crashes Excel

[geoB]

In a workbook originally designed in XL2007 but ported to XL2000:

The workbook contains a range of external text data (a Quicken export) that is updated on open. The data will then be used to populate scenarios. Because the line items in the data may change the code below steps through the line items to create range names and assign their values. At the end an existing scenario is deleted and recreated. edit: after the code runs Excel crashes when clicking on Tools, Scenarios.

I've narrowed the source of the crash down to the line that creates the scenario. (Excel also crashes if I use ChangeScenario rather than delete and create.)

Is there a work-around? Or have I misused the Scenarios object?

Thanks.

George

Sub MakeRangeNames()
Dim sht As Worksheet, intRow As Long, intCol As Long, rngStart As Range
Dim blnTotal As Boolean, blnNameExists As Boolean, blnEmpty As Boolean
Dim strName As String, dicRangeNames As Dictionary, arrValues()
Dim strAddresses As String, strCell As String, lngValues As Long

Set sht = Worksheets("Consolidation")
Set dicRangeNames = New Dictionary
Set rngStart = sht.UsedRange.Find("Portfolio Export")

intRow = rngStart.Row + 7
intCol = rngStart.Column + 1

While sht.Cells(intRow, intCol).Value <> "TOTAL Investments"
    strCell = sht.Cells(intRow, intCol).Address
    blnTotal = Range(strCell).Value Like "TOTAL*"
    strName = rangeNameCreate(Range(strCell).Value)
    blnNameExists = dicRangeNames.Exists(strName)
    blnEmpty = IsEmpty(Range(strCell).Offset(0, 2).Value)
    If Not blnTotal And Not blnEmpty Then
        'create scenario cells and values
        lngValues = lngValues + 1
        strAddresses = strAddresses & sht.Cells(intRow, intCol + 2).Address & ","
        ReDim Preserve arrValues(lngValues)
        arrValues(lngValues) = sht.Cells(intRow, intCol + 2).Value
        If Not blnNameExists Then
            sht.Cells(intRow, intCol + 2).Name = strName
            dicRangeNames.Add Key:=strName, Item:=sht.Cells(intRow, intCol + 2).Address
        End If
    End If
    intRow = intRow + 1
Wend
sht.Scenarios("Current").Delete
strAddresses = Left(strAddresses, Len(strAddresses) - 1)
sht.Scenarios.Add Name:="Current", ChangingCells:=sht.Range(strAddresses), Values:=arrValues
'sht.Scenarios("Current").ChangeScenario sht.Range(strAddresses), arrValues