VBA For Loop Optimization. Loop slow in excel 2013.

jrwrita

Board Regular
Joined
May 7, 2015
Messages
206
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.


Code:
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:

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

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

jrwrita

Board Regular
Joined
May 7, 2015
Messages
206

ADVERTISEMENT

bump
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,451
Office Version
  1. 2010
Platform
  1. Windows
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

Board Regular
Joined
May 7, 2015
Messages
206

ADVERTISEMENT

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

Well-known Member
Joined
Dec 23, 2017
Messages
1,451
Office Version
  1. 2010
Platform
  1. Windows
you need to do something like this obviously I can't test it:
Code:
' 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
 
Last edited:

jrwrita

Board Regular
Joined
May 7, 2015
Messages
206
I am getting a type mismatch on

Code:
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,

Code:
    Dim dataWs As Worksheet
    Set dataWs = Worksheets("database")
Here is the full code of mine from beggining

Code:
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
 
Last edited:

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,451
Office Version
  1. 2010
Platform
  1. Windows
chagen the code to this:
Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,108,973
Messages
5,525,983
Members
409,673
Latest member
Riseee

This Week's Hot Topics

Top