VBA For Loop Optimization. Loop slow in excel 2013.

[jrwrita]

Hi all,

I have a code below that works perfectly fine in excel 2010. I've upgraded to 2013 and now my excel gets the not responding issue, along with the excel not working. I need help optimizing this for use in excel 2013.

Any help would be appreciated.

#Empty is a string btw.

For thisScen = 1 To UBound(stressScenMapping, 1)


        thisEqShocks = filterIn(eqShocks, 2, stressScenMapping(thisScen, 1), keepcols)


        If thisEqShocks(1, 1) = "[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Empty]#Empty[/URL] " Then
            For i = 2 To nRows
                If dataCols(i, 4) <> "Excel" And dataCols(i, 4) <> "OBI" And (dataCols(i, 1) = "value1" Or dataCols(i, 1) = "value2") Then
                    dataWs.Cells(i, stressScenMapping(thisScen, 3)).Value = "No shock found"
                End If
            Next i
        Else                                     'calculate shocks
            Call quicksort(thisEqShocks, 3, 1, UBound(thisEqShocks, 1))
            For i = 2 To nRows
                If dataCols(i, 4) <> "Excel" And dataCols(i, 4) <> "ITS" And (dataCols(i, 1) = "value1" Or dataCols(i, 1) = "value2" Or dataCols(i, 1) = "value3") Then
                    thisCurrRow = findInArrCol(dataCols(i, 3), 3, thisEqShocks)
                    If thisCurrRow = 0 Then      'could not find currency so use generic shock
                        thisCurrRow = findInArrCol("OTHERS", 3, thisEqShocks)
                    End If
                    If thisCurrRow = 0 Then
                        dataWs.Cells(i, stressScenMapping(thisScen, 3)).Value = "No shock found"
                    Else
                        dataWs.Cells(i, stressScenMapping(thisScen, 3)).Value = Replace(dataCols(i, 2), "-", 0) * (thisEqShocks(thisCurrRow, 4) - 1)
                    End If
                End If
            Next i
        End If


    Next thisScen

quicksort function:

	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

 

[jrwrita]

bump

 

[jrwrita]

bump

 

[jrwrita]

bump

 

[jrwrita]

bump

 

[offthelip]

Your code is doing a double loop and accessing individual cells, this is always going to be a slow macro whatever system you are running on. It would appear that you are writing "fixed " stuff into these cells, not formula . However I can't tell what else is on the worksheet. however if the worksheet just contains data and no formula , then you can speed up your macro by a factor of 1000 or so, by loading the entire sheet into a variant array, then doing the double loop on the variant array and then write it back to the worksheet.

 

[jrwrita]

Your code is doing a double loop and accessing individual cells, this is always going to be a slow macro whatever system you are running on. It would appear that you are writing "fixed " stuff into these cells, not formula . However I can't tell what else is on the worksheet. however if the worksheet just contains data and no formula , then you can speed up your macro by a factor of 1000 or so, by loading the entire sheet into a variant array, then doing the double loop on the variant array and then write it back to the worksheet.

Yes it is fixed stuff, not formulas, I just wanted to see if I could replace this code with formulas to get the fixed stuff. But formulas seem inefficient.
Can you help speed it up? Maybe help me with the loops and making this more efficient?

 

[offthelip]

you need to do something like this obviously I can't test it:

' load entire Dataws sheet into a variant array
With dataws

lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
datawsarray = Worksheets(dataws).Range(Cells(1, 1), Cells(lastrow, lastcol))


For thisScen = 1 To UBound(stressScenMapping, 1)




        thisEqShocks = filterIn(eqShocks, 2, stressScenMapping(thisScen, 1), keepcols)




        If thisEqShocks(1, 1) = "#Empty " Then
            For i = 2 To nRows
                If dataCols(i, 4) <> "Excel" And dataCols(i, 4) <> "OBI" And (dataCols(i, 1) = "value1" Or dataCols(i, 1) = "value2") Then
' note cells reference changed to variant array
                    datawsarray(i, stressScenMapping(thisScen, 3)).Value = "No shock found"
                End If
            Next i
        Else                                     'calculate shocks
            Call quicksort(thisEqShocks, 3, 1, UBound(thisEqShocks, 1))
            For i = 2 To nRows
                If dataCols(i, 4) <> "Excel" And dataCols(i, 4) <> "ITS" And (dataCols(i, 1) = "value1" Or dataCols(i, 1) = "value2" Or dataCols(i, 1) = "value3") Then
                    thisCurrRow = findInArrCol(dataCols(i, 3), 3, thisEqShocks)
                    If thisCurrRow = 0 Then      'could not find currency so use generic shock
                        thisCurrRow = findInArrCol("OTHERS", 3, thisEqShocks)
                    End If
' note cells references changed to variant array
                    If thisCurrRow = 0 Then

                        datawsarray(i, stressScenMapping(thisScen, 3)).Value = "No shock found"
                    Else
                        datawsarray(i, stressScenMapping(thisScen, 3)).Value = Replace(dataCols(i, 2), "-", 0) * (thisEqShocks(thisCurrRow, 4) - 1)
                    End If
                End If
            Next i
        End If




    Next thisScen
' now write the entire sheet back again
 Worksheets(dataws).Range(Cells(1, 1), Cells(lastrow, lastcol)) = datawsarray
End With
End Sub

 

[jrwrita]

I am getting a type mismatch on

datawsarray = Worksheets(dataWs).Range(Cells(1, 1), Cells(lastRow, lastCol))

datawsarray is empty. For some reason is is not finding worksheets(dataWs).

But i do define it earlier in the code,

    Dim dataWs As Worksheet
    Set dataWs = Worksheets("database")

Here is the full code of mine from beggining

Public Sub mrexcel()


    Application.ScreenUpdating = False
    
    Dim i As Long, thisScen As Long, nRows As Long, nCols As Long




      
    Dim stressWS As Worksheet
    Set stressWS = Worksheets("EQ_Shocks")
    Unprotect_Tab ("EQ_Shocks")
    nRows = lastWSrow(stressWS)
    nCols = lastWScol(stressWS)
    
    Dim readcols() As Long
    ReDim readcols(1 To nCols)
    For i = 1 To nCols
        readcols(i) = i
    Next i


    Dim eqShocks() As Variant
    eqShocks = colsFromWStoArr(stressWS, readcols, False)


'    'close file
'    stressWB.Close savechanges:=False
    
    'read in database columns
    Dim dataWs As Worksheet
    Set dataWs = Worksheets("database")
    
    
    
    
    nRows = lastRow(dataWs)
    nCols = lastCol(dataWs)
           
    Dim dataCols() As Variant
    Dim riskSourceCol As Long
    riskSourceCol = getWScolNum("RiskSource", dataWs)


    ReDim readcols(1 To 4)
    readcols(1) = getWScolNum("RiskReportProductType", dataWs)
    readcols(2) = getWScolNum("Fair Value (USD)", dataWs)
    readcols(3) = getWScolNum("Source Currency of the CUSIP that is denominated in", dataWs)
    readcols(4) = riskSourceCol
    
    dataCols = colsFromWStoArr(dataWs, readcols, True)
    
    'read in scenario mappings
    Dim mappingWS As Worksheet
    Set mappingWS = Worksheets("mapping_ScenNames")
    
    Dim stressScenMapping() As Variant
    ReDim readcols(1 To 2): readcols(1) = 1: readcols(2) = 2
    stressScenMapping = colsFromWStoArr(mappingWS, readcols, False, 2) 'include two extra columns to hold column number for IR and CR shocks
    
    For i = 1 To UBound(stressScenMapping, 1)
        stressScenMapping(i, 3) = getWScolNum(stressScenMapping(i, 2), dataWs)
        If stressScenMapping(i, 2) <> "NA" And stressScenMapping(i, 3) = 0 Then
            MsgBox ("Could not find " & stressScenMapping(i, 2) & " column in database")
            Exit Sub
        End If
    Next i
    
    ReDim readcols(1 To 4): readcols(1) = 1: readcols(2) = 2: readcols(3) = 3: readcols(4) = 4
    stressScenMapping = filterOut(stressScenMapping, 2, "NA", readcols)


    'calculate stress and write to database
    Dim thisEqShocks() As Variant
    
    Dim keepcols() As Long
    ReDim keepcols(1 To UBound(eqShocks, 2))
    For i = 1 To UBound(keepcols)
        keepcols(i) = i
    Next i
    
    Dim thisCurrRow As Long

For thisScen = 1 To UBound(stressScenMapping, 1)




        thisEqShocks = filterIn(eqShocks, 2, stressScenMapping(thisScen, 1), keepcols)




        If thisEqShocks(1, 1) = "#Empty " Then
            For i = 2 To nRows
                If dataCols(i, 4) <> "Excel" And dataCols(i, 4) <> "OBI" And (dataCols(i, 1) = "value1" Or dataCols(i, 1) = "value2") Then
                    dataWs.Cells(i, stressScenMapping(thisScen, 3)).Value = "No shock found"
                End If
            Next i
        Else                                     'calculate shocks
            Call quicksort(thisEqShocks, 3, 1, UBound(thisEqShocks, 1))
            For i = 2 To nRows
                If dataCols(i, 4) <> "Excel" And dataCols(i, 4) <> "ITS" And (dataCols(i, 1) = "value1" Or dataCols(i, 1) = "value2" Or dataCols(i, 1) = "value3") Then
                    thisCurrRow = findInArrCol(dataCols(i, 3), 3, thisEqShocks)
                    If thisCurrRow = 0 Then      'could not find currency so use generic shock
                        thisCurrRow = findInArrCol("OTHERS", 3, thisEqShocks)
                    End If
                    If thisCurrRow = 0 Then
                        dataWs.Cells(i, stressScenMapping(thisScen, 3)).Value = "No shock found"
                    Else
                        dataWs.Cells(i, stressScenMapping(thisScen, 3)).Value = Replace(dataCols(i, 2), "-", 0) * (thisEqShocks(thisCurrRow, 4) - 1)
                    End If
                End If
            Next i
        End If




    Next thisScen

    Application.ScreenUpdating = True


End Sub

 

[offthelip]

chagen the code to this:

With Worksheets("database")
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
datawsarray = .Range(Cells(1, 1), Cells(lastrow, lastcol))
End With

Personally i never set a variable to range it is usually much better to load the range into an array, also I find when a variable is set to a range it obfuscates what you are operating on.