VBA, Code runs fine in excel 2010, slow and not responding error in 2013

jrwrita

Board Regular
Joined
May 7, 2015
Messages
206
Previously when running my code in 2010 excel version (Version 14.0.7165.5000), it runs in 4 minutes. (however if I run it a second time, it doesnt work)
When switching to 2013 I get 'excel not responding' or it just excel hangs.
The code opens a files from a directory, loads them into my excel sheet and compiles and transforms some data.


Does anyone know why this is? Is there some function I am using that works in 2010 but not in 2013? I have included the code below.


Code:
    Public Sub calculateIRStressScenarioShock_wrapper()
     
        OptimizeVBA True
     
        Dim i As Long, count As Long, nCols As Long
        Dim keepcols() As Long
        Dim exportPath As String
     
     
        Dim discountCurveNames() As Variant
     
        ReDim keepcols(1 To 1) As Long: keepcols(1) = 1
     
        discountCurveNames = colsFromWStoArr(Sheets("Discount_Curves"), keepcols, False)
     
        discountCurveNames = distinctArrCol(discountCurveNames, 1, True) 'in case there are duplicate entries
     
        'generate list of scenario file names
        Dim filepath As String
        filepath = get_this_data("Tables", "B", "scenarioDef_folder", "C")
     
        Dim file As Variant
        file = Dir(filepath)
        While (file <> "")
            count = count + 1
            file = Dir
        Wend
     
        Dim scenNames() As Variant
        ReDim scenNames(1 To count, 1)
     
        file = Dir(filepath)
        i = 1
        While (file <> "")
            scenNames(i, 1) = leftOfLastChar(CStr(file), ".")
            file = Dir
            i = i + 1
        Wend
     
        'get export filepath
        exportPath = ""
     
        'read in curve names to market data curve name mapping
        Dim curveNameToMarketData() As Variant
        ReDim keepcols(1 To 2)
        keepcols(1) = getWScolNum("Stress Scenario Definition Curve Name", Sheets("mappings"))
        keepcols(2) = getWScolNum("Market Data Curve Name", Sheets("mappings"))
        curveNameToMarketData = colsFromWStoArr(Worksheets("mappings"), keepcols, False)
        Call quicksort(curveNameToMarketData, 1, 1, UBound(curveNameToMarketData, 1))
     
        'load curve market data into array
        Dim riskDate As Date
        riskDate = Sheets("Start").Range("d2").Value
     
        Dim curveDataWS As Worksheet
        Dim curveDataPath As String
        Dim lastrow As Long
     
     
        Set curveDataWS = ActiveWorkbook.Worksheets("CurveMktData_IR")
        lastrow = lastWSrow(curveDataWS)
     
        'read into array
        Dim curveData() As Variant
     
        nCols = lastWScol(curveDataWS)
     
        ReDim keepcols(1 To nCols)
        For i = 1 To nCols
            keepcols(i) = i
        Next i
     
        curveData = colsFromWStoArr(curveDataWS, keepcols, True)
     
        'filter array
        curveData = filterIn(curveData, 1, riskDate, keepcols)
     
        '*********************************************************************************************************************
        'check whether curve names to market data curve name mapping is incomplete, if yes, output the missing curve names
        Dim thisCurveMapRow As Long
        Dim errorFound As Boolean
        Dim thisCurve As Long
        errorFound = False
     
        Dim errorStr As String
        errorStr = ""
     
        For thisCurve = 1 To UBound(discountCurveNames, 1)
            thisCurveMapRow = findInArrCol(discountCurveNames(thisCurve, 1), 1, curveNameToMarketData)
     
            If thisCurveMapRow = 0 Then
                errorFound = True
                errorStr = errorStr & discountCurveNames(thisCurve, 1) & Chr(10)
            End If
        Next thisCurve
     
        'write error message
        If errorFound Then
            MsgBox "Could not map the following items. Please add those curves into the CurveNameMapping tab." & Chr(10) & errorStr
            Exit Sub
        Else
            'Worksheets("instructions").Range("instructions_mappingError").Value = "No errors"
        End If
        '*********************************************************************************************************************
     
        'term buckets
        Dim termBuckets(1 To 15) As Variant
        termBuckets(1) = 0
        termBuckets(2) = 30
        termBuckets(3) = 91
        termBuckets(4) = 182
        termBuckets(5) = 365
        termBuckets(6) = 730
        termBuckets(7) = 1095
        termBuckets(8) = 1461
        termBuckets(9) = 1826
        termBuckets(10) = 2556
        termBuckets(11) = 3652
        termBuckets(12) = 5478
        termBuckets(13) = 7305
        termBuckets(14) = 10957
        termBuckets(15) = 21914
     
        'risk free currency to curve mapping
        Dim currToRiskFree() As Variant
        ReDim keepcols(1 To 2)
        keepcols(1) = getWScolNum("Currency", Sheets("mappings"))
        keepcols(2) = getWScolNum("Risk free curve", Sheets("mappings"))
        currToRiskFree = colsFromWStoArr(Worksheets("mappings"), keepcols, False)
     
        'generate shocks
        Call generateIRandCRshocks(filepath, scenNames, curveNameToMarketData, curveData, discountCurveNames, currToRiskFree, termBuckets, exportPath)
     
        OptimizeVBA False
    End Sub

which calls:


Code:
    Public Sub generateIRandCRshocks(scenPath As String, scenNames() As Variant, curveNameToMarketData() As Variant, curveData() As Variant, curveNames() As Variant, currToRiskFree() As Variant, termBuckets() As Variant, exportPath As String)
        
        Dim i As Long, j As Long
        Dim thisScen As Long, thisCurve As Long, thisBucket As Long
        Dim lastrow As Long, thisRow As Long
        Dim thisArr() As Variant
        Dim thisArrRow As Long, thisCurveMapRow As Long, thisCurveDataRow As Long, thisRiskFreeRow As Long
        
        Dim sourceWB As Workbook
        Dim sourceWS As Worksheet
        
        'ensure data to be searched is sorted
        Call quicksort(curveData, 2, 1, UBound(curveData, 1))
        Call quicksort(curveNameToMarketData, 1, 1, UBound(curveNameToMarketData, 1))
        
        'create data structure to hold shocks
        Dim arrshocks() As Variant
        ReDim arrshocks(1 To UBound(scenNames) * UBound(curveNames) * 2, 1 To 3 + UBound(termBuckets))
        
        'list column names to be read in ***code assumes all files have the same format!
        Dim readcols() As Variant
        ReDim readcols(1 To 9)
        readcols(1) = 1 'RF attribute1
        readcols(2) = 2 'RF attribute2
        readcols(3) = 3 'RF attribute3
        readcols(4) = 4 'RF attribute4
        readcols(5) = 5 'RF attribute5
        readcols(6) = 6 'RF attribute6
        readcols(7) = 7 'RF attribute7
        readcols(8) = 10 'Shock Value
        readcols(9) = 11 'Shock Type
        
        thisRow = 1
        For thisScen = 1 To UBound(scenNames, 1)
        
            'MsgBox (scenNames(thisScen, 1))
        
            'open file
            Application.EnableEvents = False
            Set sourceWB = Workbooks.Open(filename:=scenPath & scenNames(thisScen, 1) & ".csv", UpdateLinks:=False, ReadOnly:=True)
            sourceWB.Activate
            Application.EnableEvents = True
            
            Set sourceWS = sourceWB.Worksheets(scenNames(thisScen, 1))
            lastrow = lastWSrow(sourceWS)
            
            'read into array and concatenate attribute columns
            ReDim thisArr(1 To lastrow - 1, 1 To 4)
            For i = 2 To lastrow
                j = 1
                    thisArr(i - 1, 1) = sourceWS.Cells(i, readcols(j))
                For j = 2 To 7
                    thisArr(i - 1, 1) = thisArr(i - 1, 1) & "|" & sourceWS.Cells(i, readcols(j))
                Next j
                j = 8
                    thisArr(i - 1, 2) = sourceWS.Cells(i, readcols(j))
                j = 9
                    thisArr(i - 1, 3) = sourceWS.Cells(i, readcols(j))
                j = 2
                    thisArr(i - 1, 4) = sourceWS.Cells(i, readcols(j)) 'currency entered again in its own column for easy lookup later
            Next i
            
            'close file
            sourceWB.Close savechanges:=False
                    
            'sort array
            Call quicksort(thisArr, 1, 1, UBound(thisArr, 1))
            
            'get risk free shocks: array is in format [Currency TermBucket]
            Dim riskFree() As Variant
            ReDim riskFree(1 To UBound(currToRiskFree), 1 To UBound(termBuckets) + 1)
            For i = 1 To UBound(riskFree, 1)
            
                riskFree(i, 1) = currToRiskFree(i, 1)
            
                For thisBucket = 1 To UBound(termBuckets)
                
                    thisArrRow = findInArrCol(currToRiskFree(i, 2) & "|" & termBuckets(thisBucket) & "||SHOCK", 1, thisArr)
                    
                    If thisArrRow = 0 Then
                        MsgBox ("Error calculating risk free rate: Could not find " & riskFree(i, 2) & "|" & termBuckets(thisBucket) & "||SHOCK in" & scenNames(thisScen, 1))
                        Exit Sub
                    End If
                    
                    'absolute shock
                    If thisArr(thisArrRow, 3) = "non-parallel shift" Then
                        riskFree(i, thisBucket + 1) = thisArr(thisArrRow, 2) * 10000
    
    
                    'relative shock
                    ElseIf thisArr(thisArrRow, 3) = "variable factor" Then
                        thisCurveMapRow = findInArrCol(currToRiskFree(i, 2), 1, curveNameToMarketData) 'get mapping market data curve name
                        thisCurveDataRow = findInArrCol(curveNameToMarketData(thisCurveMapRow, 2), 2, curveData) 'get curve data
                        
                        'absolute shock = 10000 * abs(yield) * (relative shock - 1)
                        riskFree(i, thisBucket + 1) = 10000 * Abs(curveData(thisCurveDataRow, 2 + thisBucket)) * (thisArr(thisArrRow, 2) - 1)
    
    
                    'special case for SRF credit scenarios
                    ElseIf thisArr(thisArrRow, 3) = "NOT DEFINED" And (scenNames(thisScen, 1) = "Credit_Spread_Pos_Basis" Or scenNames(thisScen, 1) = "Credit_Spread_Neg_Basis" Or scenNames(thisScen, 1) = "Credit_Spread_Zero_Basis") Then
                        riskFree(i, thisBucket + 1) = 0
                    
                    Else
                        MsgBox ("Error calculating risk free rate: Code can not handle Shock Type " & thisArr(thisArrRow, 3) & " for " & currToRiskFree(i, 2) & " in " & scenNames(thisScen, 1))
                        Exit Sub
                    End If
                Next thisBucket
            Next i
            
            Call quicksort(riskFree, 1, 1, UBound(riskFree, 1))
            
            'step through each curve and calculate shocks
            For thisCurve = 1 To UBound(curveNames, 1)
                    
                arrshocks(thisRow, 1) = "IR"
                arrshocks(thisRow + 1, 1) = "CR"
                arrshocks(thisRow, 2) = scenNames(thisScen, 1)
                arrshocks(thisRow + 1, 2) = scenNames(thisScen, 1)
                arrshocks(thisRow, 3) = curveNames(thisCurve, 1)
                arrshocks(thisRow + 1, 3) = curveNames(thisCurve, 1)
                
                For thisBucket = 1 To UBound(termBuckets, 1)
                    
                    'find curve in array
                    thisArrRow = findInArrCol(curveNames(thisCurve, 1) & "|" & termBuckets(thisBucket) & "||SHOCK", 1, thisArr)
                    
                    If thisArrRow = 0 Then 'could not find curve in array
                        
                        arrshocks(thisRow, 3 + thisBucket) = "ERROR: Could not find curve in scenario file"
                        arrshocks(thisRow + 1, 3 + thisBucket) = "ERROR: Could not find curve in scenario file"
                    
                    Else
                        'write shock to array
                        thisRiskFreeRow = findInArrCol(thisArr(thisArrRow, 4), 1, riskFree)
                        
                        'absolute shock
                        If thisArr(thisArrRow, 3) = "non-parallel shift" Then
                        
                            'arrshocks(thisrow, 3 + thisBucket) = thisArr(thisArrRow, 2) * 10000 'TOTAL SHOCK
                            arrshocks(thisRow, 3 + thisBucket) = riskFree(thisRiskFreeRow, thisBucket + 1) 'IR SHOCK
                            arrshocks(thisRow + 1, 3 + thisBucket) = thisArr(thisArrRow, 2) * 10000 - arrshocks(thisRow, 3 + thisBucket) 'CR SHOCK
    
    
                        'relative shock
                        ElseIf thisArr(thisArrRow, 3) = "variable factor" Then
                            
                            thisCurveMapRow = findInArrCol(curveNames(thisCurve, 1), 1, curveNameToMarketData) 'get mapping market data curve name
                            thisCurveDataRow = findInArrCol(curveNameToMarketData(thisCurveMapRow, 2), 2, curveData) 'get curve data
                            
                            'absolute shock = 10000 * abs(yield) * (relative shock - 1)
                            'arrshocks(thisrow, 3 + thisBucket) = 10000 * Abs(curveData(thisCurveDataRow, 1 + thisBucket)) * (thisArr(thisArrRow, 2) - 1) 'TOTAL SHOCK
                            arrshocks(thisRow, 3 + thisBucket) = riskFree(thisRiskFreeRow, thisBucket + 1) 'IR SHOCK
                            arrshocks(thisRow + 1, 3 + thisBucket) = 10000 * Abs(curveData(thisCurveDataRow, 2 + thisBucket)) * (thisArr(thisArrRow, 2) - 1) - arrshocks(thisRow, 3 + thisBucket)
    
    
                        'special case for SRF credit scenarios
                        ElseIf thisArr(thisArrRow, 3) = "NOT DEFINED" And (scenNames(thisScen, 1) = "Credit_Spread_Pos_Basis" Or scenNames(thisScen, 1) = "Credit_Spread_Neg_Basis" Or scenNames(thisScen, 1) = "Credit_Spread_Zero_Basis") Then
                            arrshocks(thisRow, 3 + thisBucket) = 0
                            arrshocks(thisRow + 1, 3 + thisBucket) = 0
                        Else
                            arrshocks(thisRow, 1) = "IR - ERROR"
                            arrshocks(thisRow, 3 + thisBucket) = "ERROR: Shock Type '" & thisArr(thisArrRow, 3) & "' not coded for in this subroutine"
                            arrshocks(thisRow + 1, 1) = "CR - ERROR"
                            arrshocks(thisRow + 1, 3 + thisBucket) = "ERROR: Shock Type '" & thisArr(thisArrRow, 3) & "' not coded for in this subroutine"
                        End If
                        
                    End If
                    
                Next thisBucket
            
            thisRow = thisRow + 2
            
            Next thisCurve
        Next thisScen
    
    
        'create file and save array data to it
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells.ClearContents
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 1).Value = "Shock type"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 2).Value = "Scenario"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 3).Value = "Curve"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 4).Value = "0"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 5).Value = "30"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 6).Value = "91"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 7).Value = "182"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 8).Value = "365"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 9).Value = "730"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 10).Value = "1095"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 11).Value = "1461"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 12).Value = "1826"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 13).Value = "2556"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 14).Value = "3652"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 15).Value = "5478"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 16).Value = "7305"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 17).Value = "10957"
        ActiveWorkbook.Sheets("IR_CR_Shocks").Cells(1, 18).Value = "21914"
        
        Call writeArrToWS(arrshocks, ActiveWorkbook.Sheets("IR_CR_Shocks").Range("A2"), True, UBound(arrshocks, 1), UBound(arrshocks, 2))
        
    
    
           
    End Sub

Other included calls:


1)


Code:
   Public Sub writeArrToWS(arr() As Variant, startCell As Range, fromTop As Boolean, nRows As Long, nCols As Long)
    
    
        Dim i As Long, j As Long, startRow As Long, startCol As Long
        Dim thisWS As Worksheet
        Dim writeVal As Variant
        
        Set thisWS = startCell.Worksheet
        
        startRow = startCell.row
        startCol = startCell.Column
        
        'clear
        For i = 1 To nRows
            For j = 1 To nCols
                thisWS.Cells(startRow + i - 1, startCol + j - 1).value = ""
            Next j
        Next i
        
        'write
        For i = 1 To WorksheetFunction.Min(nRows, UBound(arr, 1))
            For j = 1 To nCols
                If fromTop Then writeVal = arr(i, j) Else writeVal = arr(UBound(arr, 1) - i + 1, j)
                thisWS.Cells(startRow + i - 1, startCol + j - 1).value = writeVal
            Next j
        Next i
    
    
    End Sub

2)


Code:
    Sub quicksort(ByRef arr() As Variant, ByVal sortCol As Long, ByVal left As Long, ByVal right As Long)
     
        If right > left Then
            Dim pivotIndex As Long
            pivotIndex = left + Int((right - left) / 2)
     
            Dim pivotIndexNew As Long
            pivotIndexNew = partition(arr, sortCol, left, right, pivotIndex)
            Call quicksort(arr, sortCol, left, pivotIndexNew - 1)
            Call quicksort(arr, sortCol, pivotIndexNew + 1, right)
        End If
     
    End Sub
 

Some videos you may like

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

JonXL

Active Member
Joined
Feb 5, 2018
Messages
357
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Are you able to Break the code execution when it hangs to figure out where it's sticking?
 

jrwrita

Board Regular
Joined
May 7, 2015
Messages
206
Are you able to Break the code execution when it hangs to figure out where it's sticking?

No, usually i get an excel not responding or it will just say running in the vba editor and stays like that. Can't really break it, it freezes alot.
 

JonXL

Active Member
Joined
Feb 5, 2018
Messages
357
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Have you tried stepping through it with F8 (and screen updating enabled)?
 

jrwrita

Board Regular
Joined
May 7, 2015
Messages
206
Have you tried stepping through it with F8 (and screen updating enabled)?

Yes, sorry, it stops responding at this line, or the line above this one
Code:
[COLOR=#333333]                            thisCurveDataRow = findInArrCol(curveNameToMarketData(thisCurveMapRow, 2), 2, curveData) 'get curve data[/COLOR]
 
Last edited:

jrwrita

Board Regular
Joined
May 7, 2015
Messages
206
Have you tried stepping through it with F8 (and screen updating enabled)?

Just steps through each line, getting not resonding when getting to this sub
Code:
writeArrtoWS(arr()
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,109,064
Messages
5,526,566
Members
409,711
Latest member
Klaskefar

This Week's Hot Topics

Top