Question

我正在构建一个目前看起来像这样的模型 - 输入表 - ＆gt;基本的Excel功能 - ＆gt;输出表。基本的东西吧？！

我希望通过添加VBA生成的输出（New Sheet）使模型更具动态性，仅根据以下内容提取满足特定条件的数据：

Sub GenerateTargets()
'Dim UpperRange As Double
'Dim LowerRange As Double
'Dim Percentile As Double
'Dim Test
'Dim Total Revenue {Note: [This is a header in the output sheet] [should I use Array or Range? If array is it Stat or Dynamic] I might change the input later on and increase the number of observations}


'Read Values in Cells
UpperRange = Worksheets("sheet2").Cells(x, y).Value
LowerRange = Worksheets("sheet2").Cells(x, y).Value

Test = UpperRange > Percentile > LowerRange

Case Test Is True
    [This is the test I want to generate]

Case Test Is False
    [I do not want this to show in my new sheet]

[Here I would like to add another Case to stop counting if [Total revenue = ##]

End Sub

如何要求它在输出中生成相同的标题/数据但消除错误的情况，同时在达到某个阈值时停止计数。

感谢任何帮助/建议 -

Answer 1

如果我理解正确，请查看此代码。您不需要Select Case，因为您只想在“TEST”为TRUE时执行代码。您可以在FOR循环内检查“收入”条件。您可以使用动态数组来存储值，然后最后写入OUTPUT表。

Sub GenerateTargets()
    Dim UpperRange As Double, LowerRange As Double, Percentile As Double
    Dim Rev As Double
    Dim Test As Boolean
    Dim Output() As String

    Rev = Somevalue '<~~ Revenue

    '~~> Read Values in Cells
    UpperRange = Worksheets("sheet2").Cells(x, y).Value
    LowerRange = Worksheets("sheet2").Cells(x, y).Value

    '~~> Test Condition
    'Test = UpperRange > Percentile > LowerRange

    If Test = True Then
        '~~> Use For Loop here to store values in a dynamic array
        '~~> Use Redim Preserve to store new values

        '~~> Create a condition for revenue and exit FOR loop if
        '~~> the condition is met
        ' If Rev = 0 Then Exit For

        '~~> Store results in the output worksheet if the array is not empty
    End If
End Sub

关注

这是你想要做的吗？（如果没有样本文件，代码就会失败）。我已对代码进行了评论，以便您在理解代码时没有任何问题。

Option Explicit

Sub GenerateTargets()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim UpperRange As Double, LowerRange As Double, Percentile As Double
    Dim lastRowWs1 As Long, lastRowWs2 As Long, i as Long

    '~~> Sheet where data needs to be copied
    Set ws1 = Sheets("Sheet1")
    lastRowWs1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1

    '~~> Sheet where the data needs to be compared
    Set ws2 = Sheets("Sheet2")
    '~~> Read Values in Cells
    UpperRange = ws2.Range("L2").Value
    LowerRange = ws2.Range("L3").Value
    lastRowWs2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row

    '~~> Starting from the 3rd row
    For i = 3 To lastRowWs2
        '~~> Get Percentile Value for comparision
        Percentile = ws2.Range("B" & i).Value

        '~~> Test Condition and proceed if true
        If UpperRange > Percentile And LowerRange < Percentile Then
            '~~> Copy range A to I from Sheet2 and paste it in Sheet1
            ws2.Range("A" & i & ":I" & i).Copy _
            ws1.Range("A" & lastRowWs1)
            lastRowWs1 = lastRowWs1 + 1
        End If
    Next i
    Application.CutCopyMode = False
End Sub

VBA生成的输出：只有满足新工作表中某些条件的数据

1 个答案: