VBA/公式、工作表之间的映射

Question

我有一段代码在 Excel 2013 上运行时遇到问题。2010 工作正常。

我一直在考虑只做公式，因为我无法让它发挥作用。

逻辑是这样的

1. 如果存在以下条件，则仅在工作表 X 中填充值:在工作表 A 中，如果列 a = 值 1、值 2 或值 3和 b 列 <> 值 4，<> 值 5

2. 然后从工作表 X 到工作表 Y 查找标题。这些标题将位于工作表 Y 的 c 列中。

3. 对于与工作表 Y col c 匹配的标题，查找工作表 X.c 列和工作表 Y.d 列的类似数据。将使用这些作为工作表 Y 中下一列的查找。对于不匹配的地方，使用“OTHERS”作为值。

4. 对于匹配的标题/列，返回工作表 Y 列 e(值)并乘以工作表 X 列 d。减一。

5. 将所有这些值返回到表头所在的位置。

Sheet X(实际上会计算堆栈和溢出列中的以下公式)

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

我读了一篇橡皮鸭文章，并受到启发，将其从类似脚本的代码转变为类似代码的代码。 (我使用 type 而不是 private pVar 抱歉鸭子让你在这一次失败了哈哈)不过我下面的评论仍然有效。我对 5000 个单元进行了测试，该代码平均执行时间不到一秒。

本工作簿内容:

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

模块内部命名工厂:

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

内部模块命名测试:

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

内部类模块命名项目:

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