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

 

[offthelip]

try changing the write back of the array to values only:

.Range(.Cells(1, 1), .Cells(lastrow, lastcol)).value = datawsarray

 

[offthelip]

I have tried what I suggested in #21 and it doesn't work. the solution is to write the variant array back to the table. Note that to do this you must define the rangfe where you pick up DatawSarray to be coincident with the data in the table
then use this code to write it back:

Dim myTable As ListObject

Worksheets("database").select
  Set myTable = ActiveSheet.ListObjects("YourtableName")
   myTable.DataBodyRange = DataWSarray

 

[jrwrita]

Im not sure where to insert this, where can I put this?

 

[offthelip]

Where the array datawsarray is written back to the worksheet. (From my android phone)

 

[jrwrita]

' now write the entire sheet back again
Worksheets("database").select
  Set myTable = ActiveSheet.ListObjects("tbl_database")
   myTable.DataBodyRange = DataWSarray
.Range(.Cells(1, 1), .Cells(lastRowN, lastColN)) = datawsarray

This is what I currently have, but for some reason no table is being created. Is there anyway to do it without removing the table?
Because i have formulas that reference that table and they are being ruined with the removal of it.

 

[offthelip]

try getting rid of the last line because that is what overwrites the tasble e.g change the above code to:

' now write the entire sheet back again
Worksheets("database").select
  Set myTable = ActiveSheet.ListObjects("tbl_database")
   myTable.DataBodyRange = DataWSarray

 

[jrwrita]

nice it worked, but for some reasons its duplicating the headers.. in row 1 and 2 we get the headers repeated.

 

[offthelip]

I think the reason is you didn't do what I suggested in post#22
For example if the data in your table starts on row 2 then change the line where you pick up the worksheet into the array, the code:

datawsarray = .Range(.Cells([COLOR=#ff0000]2[/COLOR], 1), .Cells(lastrow, lastcol))

Then you also need to change every line that references the array because element 1 in the array now refers to row 2 in the worksheet

                        datawsarray(i-1, stressScenMapping(thisScen, 3)).Value = "No shock found"




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

I note that your i index already starts at 2 so this should be fine
Then when you write the array back it won't include the headers

 

[jrwrita]

thanks alot, if you have any page I can follow you, or a blog or training series I would be interested. Thanks again.

 

[offthelip]

No I don't have anything like that, but I do help out on here and some other Excel websites. Glad I could assist.