VBA/Formula, Mapping among sheets
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.
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
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 nativeRange.Sort
method.