VBA 生成的输出：仅在新工作表中满足特定条件的数据

Question

我正在构建一个当前看起来像这样的模型 - 输入表 --> 基本 excel 函数 --> 输出表。基本的东西对吧？！

我想通过添加 VBA 生成的输出（新工作表）使模型更加动态，仅根据以下内容提取满足特定条件的数据：

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 循环中检查“REVENUE”条件。您可以使用动态数组来存储您的值，然后最后写入 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