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. 将所有这些值返回到标题所在的表单.

表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