VBA, Code takes too long, need help optimizing

[jrwrita]

Hi,

Can anyone help improve the speed of my code? It runs extremely slow and sometimes will cause my excel to not respond.

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

 

[offthelip]

One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP. ( See my signature)

It is usually very easy to rewrite vba to avoid accessing cells in a loop, I have rewritten the first bit of yours see below. since this is in a double loop i woud expect a significant saving in time:

Dim sourcews As Variant

lastrow = lastWSrow(sourcews) ' I assume this determines the lastrow in the worksheet
' set last col to the last column numberr in you worksheet either fixed or using xleft
lastcol= 2000
sourcews = sourceWB.Worksheets(scenNames(thisScen, 1)).range(cells(1,1),cells(lastrow,lastcol))

        
        '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(i, readcols(j))
            For j = 2 To 7
                thisArr(i - 1, 1) = thisArr(i - 1, 1) & "|" & sourcews(i, readcols(j))
            Next j
            j = 8
                thisArr(i - 1, 2) = sourcews(i, readcols(j))
            j = 9
                thisArr(i - 1, 3) = sourcews(i, readcols(j))
            j = 2
                thisArr(i - 1, 4) = sourcews(i, readcols(j)) 'currency entered again in its own column for easy lookup later
        Next i

Elsewhere you have got various other functions which you haven't supplied the code, so it is difficult to know whether they access the worksheet or not. However if you go through rigourously trying to minimise accesses to worksheet, I have usually found it will speed up as code by a factor of 1000 or so.

 

[jrwrita]

Thanks! you're the man! Will have I have to rewrite this whole code with your suggestion? Or is the one you provided enough?

As for other functions, I have a basic quicksort one I found online, and another writeArrToWS ill provide here:

'

writes the nRows and nCols from arr to startCell
'if fromTop is true it starts reading from the first element of arr, otherwise it starts fromm the last element
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

 

[offthelip]

Looking at your code i am not surprised it is slow, you are continually accessing the worksheeet in a loop.
eg: this is a horrible way to clear cells is worksheet:

   For i = 1 To nRows       
    For j = 1 To nCols
            thisWS.Cells(startRow + i - 1, startCol + j - 1).value = ""
        Next j
    Next i

you can do it:

thisws.range(cells(startrow,startcol),cells(startrow+nrows,startcol+ncols)=""

I would suggest you do go through your whole code with the simple idea of
DO NOT ACCESS THE WORKSHEET IN LOOP

you can write an entire array back to a range on a worksheet in one access
Range (cells(1,1),cells(lastrow,lastcol))=array

 

[jrwrita]

thanks for the advice.
Also When I run the code from your first post i'm getting a compile error : ByReg Argument type Mismatch on the line lastrow = lastWSrow(sourcews).
and I also took our the dimsourcews as workbook, replaced it with variant.

 

[offthelip]

Yes , that would figure, there are a lot of changes that you need to make, I have shown you the way, keep at it, best of luck. You should end up with a macro that runs in couple of seconds with any luck.

 

[jrwrita]

hey offthelip, I notice this code runs very well in excel 2010, in 4 minutes, but excel 2013, takes very long and not respond error..
Do you know why?

 

[offthelip]

I don't have Excel 2013 so I can't help, I suggest you start a new thread for that, because it is a completely different question, which needs different experts to answer!!

 

[offthelip]

Sorry ignore this post wrong thread