VBA/Formula, Mapping among sheets

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

1. 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

2. Then lookup headers from sheet X into sheet Y. These headers will be in sheet Y column c.

3. 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.

4. for matched headers/columns return sheet Y column e (value) and multiply by sheet X. column d. minus one.

5. 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:

1. Add a helper column in Sheet Y column E like shown below. Use the following formula in E:

   =C:C&D:D
   

   

2. 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.