根据条件将不同的公式分配给单元格

Question

我已经写了一段代码，在其中我试图使用两个不同的公式和一组条件，比如如果我们将RUZ货币考虑在内。在(SW- 1Y)之间有基调的情况下，公式应为=1/(1/R208C-5+RC12/10000)，其余基调(2Y，3Y,5Y)的公式应为=1*RC-5。此条件仅适用于RUZ ccy，其余情况下，每个ccy(货币)一个公式将用于其各自的所有基调。

公式放在P列，基数放在B列

​

​

Sub Get_vpl()
    
    ' Define Constants.
    
    Const wsName As String = "DS"
    Const FirstRow As Long = 5
    Const srcCol As String = "A"
    Const tgtCol As String = "P"
    Dim Criteria As Variant
    Dim Formulas As Variant
    Criteria = Array("RUB", "TRY", "TWD", "UAH", "UYU", "VND") ' add more...
    Formulas = Array( "=1/(1/R208C[-5]+RC12/10000)", "=1*RC[-5]", "=1/(1/R232C[-5]+RC12/1)", "=1*RC[-5]", "=1*RC[-5]", "=1*RC[-5]") ' add more...
    
    ' Define the Source Column Range.
    
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook
    ' Define worksheet.
    Dim ws As Worksheet
    Set ws = wb.Worksheets(wsName)
    ' Calculate Last Non-Empty Row.
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, srcCol).End(xlUp).Row
    ' Define Source Column Range.
    Dim rng As Range
    Set rng = ws.Range(ws.Cells(FirstRow, srcCol), ws.Cells(LastRow, srcCol))
    
    ' Prepare to write to Target Column Range.
     
    ' Calculate Column Offset.
    Dim ColOffset As Long
    ColOffset = ws.Columns(tgtCol).Column - ws.Columns(srcCol).Column
    
    ' Declare variables.
    Dim CurPos As Variant ' Current Position
    Dim cel As Range      ' Current Cell Range
    
    ' Write formulas to Target Column Range.
   
    Application.ScreenUpdating = False
    ' Iterate the cell ranges in Source Range.
    For Each cel In rng.Cells
        ' Check if Current Cell Range in Source Column Range is not empty.
        If Not IsEmpty(cel) Then
            ' Try to find the value in Current Cell Range in Criteria Array
            ' and write the position to Current Position
            CurPos = Application.Match(cel, Criteria, 0)
            ' Check if value in Current Cell Range has been found
            ' in Criteria Array.
            If Not IsError(CurPos) Then
                ' Write formula from Formulas Array to current Target Cell
                ' Range, using Current Position in Criteria Array.
                cel.Offset(, ColOffset).Formula = _
                  Application.Index(Formulas, CurPos)
            End If
        End If
    Next cel
    Application.ScreenUpdating = True
    
    
End Sub

Answer 1

我对你的代码做了比预期更多的事情，因为我很难理解你需要什么。然而，我对结果相当满意，希望你也会满意。请注意，我从来没有运行过代码，因此，它可能包含小错误或打字错误，如果您指出它们，我将很乐意纠正它们。

Option Explicit

Enum Nws                ' worksheet navigation
    NwsFirstRow = 5
    NwsCcy = 1          ' Columns: A = Currency
    NwsTenor            '          B = Tenor
    NwsTarget = 16      '          P = Target
End Enum

Sub Get_vpl()
    ' 116
    
    ' Define Constants.
    Const wsName    As String = "DS"
    
    ' Declare variables.
    Dim Wb          As Workbook
    Dim Ws          As Worksheet
    Dim CcyIdx      As Integer              ' return value from CurrencyIndex()
    Dim R           As Long                 ' loop counter: rows
    
    Set Wb = ThisWorkbook
    Set Ws = Wb.Worksheets(wsName)
    Application.ScreenUpdating = False
    With Ws
        ' this syntax is easier because you need the row number R
        For R = NwsFirstRow To .Cells(.Rows.Count, NwsCcy).End(xlUp).Row
            CcyIdx = CurrencyIndex(.Cells(R, NwsCcy).Value)
            If CcyIdx >= 0 Then
                .Cells(R, NwsTarget).Formula = ChooseFormula(CcyIdx, .Cells(R, NwsTenor).Value)
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Private Function ChooseFormula(ByVal CcyIdx As Integer, _
                               ByVal Tenor As String) As String
    ' 116
    ' return the formula specified by Idx or Formula(0)
    
    Dim Idx             As Integer
    Dim Formula(2)      As String

    ' the advantage of the syntax you chose is that the array
    ' is dimensioned automatically.
    ' Here the advantage is clarity.
    Formula(0) = "=1*RC[-5]"
    Formula(1) = "=1/(1/R208C[-5]+RC12/10000)"
    Formula(2) = "=1/(1/R232C[-5]+RC12/1)"
    
    If CcyIdx = 0 Then
        If InStr("1Y,2Y,3Y,5Y", Tenor) Then Idx = 1
    End If
    ChooseFormula = Formula(Idx)
End Function

Private Function CurrencyIndex(ByVal Currcy As String) As Integer
    ' 116
    ' return -1 if not found or blank

    Dim Ccy()       As String               ' list of currencies
    Dim i           As Integer
    
    ' I added "RUZ" in position 0 (change to suit and match in ChooseFormula())
    ' this syntax uses less space but doesn't support MATCH()
    Ccy = Split("RUZ RUB TRY TWD UAH UYU VND")  ' add more...
    If Len(Trim(Currcy)) Then
        For i = UBound(Ccy) To 0 Step -1
            If StrComp(Currcy, Ccy(i), vbTextCompare) = 0 Then Exit For
        Next i
    Else
        i = -1
    End If
    CurrencyIndex = i
End Function

我发现你的标准在这种情况下相当无用。也许这就是我给它一个任务的原因。函数CurrencyIndex()返回当前货币的索引号，然后用这个数字代替实际的货币代码。为此，我将"RUZ“添加到您的数组中。我把它放在第一位，但任何其他数字都可以。

请看函数ChooseFormula()。看起来你只有3个公式。我将索引0分配给最常见的索引，并将其设为默认值。对于其余部分，CcyIdx将作为参数传递给函数，如果该索引=0，则标识"RUZ“并对其进行特殊处理。我不确定我分配的处理是100%正确或可行的，但我认为代码很简单，您应该能够根据需要修改它。注意到该函数在其当前状态下永远不会返回Formula(2)，但是您可以轻松地修改它以适应各种条件和更多可能的公式。如果你需要任何帮助，请告诉我。