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 3 Answers
Answers 1
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(ORpart is the condition of your point 1 in your question.
Answers 2
I read a rubber duck post and was inspired to turn this from script like code into code like code. 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 
Answers 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 = arr2Don the contrary,
quicksortcall 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.Sortmethod.
0 comments:
Post a Comment