VBA/Formula, Mapping among sheets - vba

Question

I have a code that I am having trouble running on excel 2013. 2010 works fine.
I've been contemplating just doing formulas because I cannot get this to work.
Here is the logic
Only fill values in sheet X if this condition exists: In Sheet A , If column a = value 1 , value 2, or value 3
and column b <> value 4, <> value 5
Then lookup headers from sheet X into sheet Y. These headers will be in sheet Y column c.
for the headers that are matched to sheet Y col c, find like data of sheet X. column c, and sheet Y. column d. Going to use these as lookup for next column in sheet Y. For where there are mismatches use 'OTHERS' as value.
for matched headers/columns return sheet Y column e (value) and multiply by sheet X. column d. minus one.
return all these values to sheet a where the headers are like.
Sheet X (below formulas in stack and overflow cols would actually be calculated)
+-------------+-------------+------------+-------+-----------------+-------------+
| conditions | condition 2 | currency | value | stack | overflow |
+-------------+-------------+------------+-------+-----------------+-------------+
| value 1 | value 10 | USD | 100 | 100 * (.75 - 1) | |
| value 2 | value 7 | XRP | 200 | 200 * (.50 - 1) | |
| value 3 | value 8 | USD | 300 | | 300*(.65-1) |
| value 1 | value 9 | XRP | 400 | | 400*(.24-1) |
+-------------+-------------+------------+-------+-----------------+-------------+
Sheet Y
+----------+----------+--------+
| header | currency | value |
+----------+----------+--------+
| stack | USD | .75 |
| stack | OTHER | .50 |
| overflow | USD | .65 |
| overflow | OTHER | .24 |
+----------+----------+--------+
This code gets slow at the for loop at the bottom of the code.
Here is my code:
Public Sub calc()
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)
'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("condition 2", dataWs)
ReDim readcols(1 To 4)
readcols(1) = getWScolNum("value", dataWs)
readcols(2) = getWScolNum("currency", dataWs)
readcols(3) = getWScolNum("condition", 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) <> "value 4" And dataCols(i, 4) <> "value 5" And (dataCols(i, 1) = "value 1" Or dataCols(i, 1) = "value 2") 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) <> "value 5" And dataCols(i, 4) <> "value 6" And (dataCols(i, 1) = "value 1" Or dataCols(i, 1) = "value 2" Or dataCols(i, 1) = "value 3") 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

Answer 1

I read a rubber duck post and was inspired to turn this from script like code into code like code. (i have use type instead of private pVar sorry ducky for failing you in this one LOL) My comment below still stands though. I tested on 5000 cells and this coded executed in under a second on average.
INSIDE THIS WORKBOOK:
Option Explicit
Sub main()
Dim startTime As Long
startTime = Tests.GetTickCount
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim lastRow As Integer
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A4:A" & lastRow), Order:=xlAscending
.SortFields.Add Key:=Range("B4:B" & lastRow), Order:=xlAscending
.Header = xlYes
.SetRange Range("A4:F" & lastRow)
.Apply
End With
Dim colOfItems As Collection
Set colOfItems = New Collection
Dim cell As Range
For Each cell In ws.Range("A4:A" & lastRow)
Dim item As Items
If cell.value <> 1 And cell.value <> 2 And cell.value <> 3 Then
Exit For
Else
Set item = Factories.newItem(ws, cell.row)
colOfItems.Add item
Set item = Nothing
End If
Next cell
Set ws = Nothing
Dim wsTwo As Worksheet
Set wsTwo = Sheets("Sheet2")
Dim row As Integer
row = 4
Dim itemcheck As Items
For Each itemcheck In colOfItems
If Tests.conditionTwoPass(itemcheck) Then
With wsTwo
.Range("A" & row) = itemcheck.conditionOne
.Range("B" & row) = itemcheck.conditionTwo
.Range("C" & row) = itemcheck.CurrencyType
.Range("D" & row) = itemcheck.ValueAmount
.Range("E" & row) = itemcheck.Stack
.Range("F" & row) = itemcheck.OverFlow
End With
row = row + 1
End If
Next itemcheck
Dim endTime As Long
endTime = Tests.GetTickCount
Debug.Print endTime - startTime
End Sub
INSIDE MODULE NAMED FACTORIES:
Public Function newItem(ByRef ws As Worksheet, ByVal row As Integer) As Items
With New Items
.conditionOne = ws.Range("A" & row)
.conditionTwo = ws.Range("B" & row)
.CurrencyType = ws.Range("C" & row)
.ValueAmount = ws.Range("D" & row)
.Stack = ws.Range("E" & row)
.OverFlow = ws.Range("F" & row)
Set newItem = .self
End With
End Function
INSIDE MODULE NAMED TESTS:
Public Declare Function GetTickCount Lib "kernel32" () As Long
Function conditionTwoPass(ByVal itemcheck As Items) As Boolean
conditionTwoPass = False
If itemcheck.conditionTwo <> 4 And itemcheck.conditionTwo <> 5 Then
conditionTwoPass = True
End If
End Function
INSIDE CLASS MODULE NAMED ITEMS:
Private pConditionOne As Integer
Private pConditionTwo As Integer
Private pCurrencyType As String
Private pValueAmount As Integer
Private pStack As String
Private pOverflow As String
Public Property Let conditionOne(ByVal value As Integer)
pConditionOne = value
End Property
Public Property Get conditionOne() As Integer
conditionOne = pConditionOne
End Property
Public Property Let conditionTwo(ByVal value As Integer)
pConditionTwo = value
End Property
Public Property Get conditionTwo() As Integer
conditionTwo = pConditionTwo
End Property
Public Property Let CurrencyType(ByVal value As String)
If value = "USD" Then
pCurrencyType = value
Else
pCurrencyType = "OTHER"
End If
End Property
Public Property Get CurrencyType() As String
CurrencyType = pCurrencyType
End Property
Public Property Let ValueAmount(ByVal value As Integer)
pValueAmount = value
End Property
Public Property Get ValueAmount() As Integer
ValueAmount = pValueAmount
End Property
Public Property Let Stack(ByVal value As String)
pStack = value
End Property
Public Property Get Stack() As String
Stack = pStack
End Property
Public Property Let OverFlow(ByVal value As String)
pOverflow = value
End Property
Public Property Get OverFlow() As String
OverFlow = pOverflow
End Property
Public Property Get self() As Items
Set self = Me
End Property

Answer 2

Here is a formula only solution, using a helper column to lookup 2 criteria (header & column) at once:
Add a helper column in Sheet Y column E like shown below. Use the following formula in E:
=C:C&D:D
Use the following formula in E2 and copy it down and right:
=IF(AND(OR($A:$A="value 1",$A:$A="value 2",$A:$A="value 3"),$B:$B<>"value 4",$B:$B<>"value 5"),$D:$D*(IFNA(VLOOKUP(E$1&$C:$C,'Sheet Y'!$E:$F,2,FALSE),VLOOKUP(E$1&"OTHER",'Sheet Y'!$E:$F,2,FALSE))-1),"")
The calculation part of the formula
$D:$D*(IFNA(VLOOKUP(E$1&$C:$C,'Sheet Y'!$E:$F,2,FALSE),VLOOKUP(E$1&"OTHER",'Sheet Y'!$E:$F,2,FALSE))-1)
looks up a combination of "header" and column C in the helper column. If it finds the combination it returns its value if not it looks up a combination of "header" and "OTHER" and returns its value to perform the calculation.
The IF(AND(OR part is the condition of your point 1 in your question.

Answer 3

the loop gets slow because it's too much interaction between excel and VBA. Put the entire loop within the VBA , filling in the 2D array and dump the result out like so:
Sheets(1).cells(1,1).Resize(Ubound(arr2D),Ubound(arr2D,2)).value2 = arr2D
on the contrary, quicksort call is probably slow in VBA, so it may make sense to sort in Excel AFTER the array is pasted back to a sheet using native Range.Sort method.