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
 
Now getting application-defined or object defined error. Not sure how I am getting this.

Ill post my updated code here, I also changed some of your variable names just so I remember it better:


Code:
Public Sub mrexcel()

    Application.ScreenUpdating = False
    
    Dim i As Long, thisScen As Long, nRows As Long, nCols As Long, lastColN As Long, lastRowN 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
    


' load entire Dataws sheet into a variant array
With Worksheets("database")
lastColN = .Cells(1, .Columns.count).End(xlToLeft).Column
lastRowN = .Cells(Rows.count, "A").End(xlUp).row
datawsarray = .Range(Cells(1, 1), Cells(lastRowN, lastColN))




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(lastRowN, lastColN)) = datawsarray


End With


Application.ScreenUpdating = True


End Sub
 
Last edited:
Upvote 0

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
which line are you getting the error on?
It is possible that you will get this error when you write the array back to the worksheet if you have got garbage in one of the cells . If this is the line which is causing the erro you can find which cell is the probelm by writing the array back one cell at a time
It will hopefully fall over at the cell which is causing the problem:
So comment out the line which writes the arayt back and put this in:
Code:
'Worksheets(dataWs).Range(Cells(1, 1), Cells(lastRowN, lastColN)) = datawsarray

For i = 1 To lastrowN
 For j = 1 To lastcoln
  Cells(i , j) = inarr(i, j)
 Next j
Next i
 
Upvote 0
sorry my mistake that line should be:
Code:
datawsarray = .Range(.Cells(1, 1), .Cells(lastrow, lastcol))
you also need to change the line at the bottom that writes it back:

Code:
.Range(.Cells(1, 1), .Cells(lastrow, lastcol)) = datawsarray
 
Upvote 0
thanks, I get past that part now,
now i get object required on
Code:
datawsarray(i, stressScenMapping(thisScen, 3)).value = Replace(dataCols(i, 2), "-", 0) * (thisEqShocks(thisCurrRow, 4) - 1)
 
Upvote 0
Try deleting the .value from each of the lines , you don't need it when writing to an array
Code:
                      datawsarray(i, stressScenMapping(thisScen, 3)) = "No shock found"                   
                    Else
                        datawsarray(i, stressScenMapping(thisScen, 3)) = Replace(dataCols(i, 2), "-", 0) * (thisEqShocks(thisCurrRow, 4) - 1)
                    End If
 
Last edited:
Upvote 0
datawsarray = .Range(.Cells(1, 1), .Cells(lastrow, lastcol))
Just helpful remark, this could be replaced with:
Rich (BB code):
.Cells(1,1).Resize(lastrow, lastcol)
Which is a little simpler/easier (i.e. doesn't need the Range wrap around) and opposite direction
Rich (BB code):
.Cells(1,1).Resize(ubound(datawsarray, 1), ubound(datawsarray, 2)).Value = datawsarray
The write back is slightly different as this accounts for an array who's size is not same size as input size
 
Last edited:
Upvote 0
thank you so much! it works from what I've seen so far.
Btw, when i run this , after it writes to dataws, why does my table disappear? I have it named as a table and this disappears.
 
Upvote 0

Forum statistics

Threads
1,213,533
Messages
6,114,179
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top