Question

我有一个代码无法在excel 2013上运行。2010工作正常。

我一直在考虑只做公式，因为我无法使它起作用。

这是逻辑

仅在存在此条件的情况下在工作表X中填写值：在工作表A中，如果列a =值1，值2或值3 b列<>值4，<>值5
然后从表格X到表格Y的查找标题。这些标题将在表格Y的列c中。
找到工作表X.列c和工作表Y.列d的数据。将这些用作在工作表Y下一列的查找。对于不匹配的地方，请使用“ OTHERS”作为值。
对于匹配的标题/列，返回工作表Y列e（值）并乘以工作表X.列d。减一
将所有这些值返回到标题类似的表a。

表格X（实际上将计算堆栈和溢出cols中的公式下方）

+-------------+-------------+------------+-------+-----------------+-------------+
|  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) |
+-------------+-------------+------------+-------+-----------------+-------------+

表格Y

+----------+----------+--------+
| header   | currency |  value |
+----------+----------+--------+
| stack    | USD      |    .75 |
| stack    | OTHER    |    .50 |
| overflow | USD      |    .65 |
| overflow | OTHER    |    .24 |
+----------+----------+--------+

此代码在代码底部的for循环中变慢。

这是我的代码：

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

这是仅公式解决方案，使用帮助程序列一次查找2个条件（标题和列）：

在工作表Y列E中添加一个帮助列，如下所示。在E中使用以下公式：
```
=C:C&D:D
```
在E2中使用以下公式并将其向下和向右复制：
```
=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),"")
```
公式的计算部分
```
$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)
```
在帮助程序列中查找“标题”和列C的组合。如果找到组合，则返回其值；否则，将查找“ header”和“ OTHER”的组合，并返回其值以执行计算。

IF(AND(OR部分是您问题中第1点的条件。

Answer 2

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 3

循环变得缓慢，因为excel和VBA之间的交互过多。将整个循环放入VBA中，填充2D数组，然后像这样转储结果：
```
Sheets(1).cells(1,1).Resize(Ubound(arr2D),Ubound(arr2D,2)).value2 = arr2D
```
相反，在VBA中，quicksort调用可能很慢，因此在使用本机Range.Sort方法将数组粘贴回到工作表之后，最好在Excel中进行排序。< / p>

VBA /公式，图纸之间的映射

3 个答案: