VBA/Formula, Mapping among sheets

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
    

    enter image description here

  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),"")
    

    enter image description here

    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.


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

enter image description here

enter image description here

enter image description here

enter image description here

enter image description here


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

Tags:

Excel

Vba