Excel VBA数组差值计算脚本新增K列Location筛选条件实现问询

修改方案 #

你只需要调整Sheet4（BA_Size）的Worksheet_Calculate事件代码，在写入Sheet1前新增K列Location的过滤逻辑即可，具体修改如下：

完整修改后代码

Private Sub Worksheet_Calculate()

Dim keyCells As Range, i As Long, diff, cKey As Range
' 定义允许保留的Location值，可根据实际需求修改
Const ALLOWED_LOCATION As String = "华东,华南,华北"
Dim allowedArr As Variant
allowedArr = Split(ALLOWED_LOCATION, ",")

'exit if togglebutton not on
If Not Worksheets("BA_Size").ToggleButton1.Value Then Exit Sub

On Error GoTo safeexit
Application.EnableEvents = False

Set keyCells = Me.Range("I6:I500")
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1

For i = 1 To UBound(myArr)
    Set cKey = keyCells(i, 1)
    If cKey.Value <> myArr(i, 1) Then
        diff = (cKey.Value - myArr(i, 1))
        'check value in Col L
        Select Case cKey.EntireRow.Columns("L").Value
            Case "John": diff = diff * cKey.EntireRow.Columns("O").Value
            Case "Mary": diff = diff * cKey.EntireRow.Columns("P").Value
            Case Else: diff = 0
        End Select
        ' 新增K列Location过滤逻辑
        Dim locationVal As String
        locationVal = Trim(cKey.EntireRow.Columns("K").Value)
        ' 判断当前Location是否在允许列表中
        If IsError(Application.Match(locationVal, allowedArr, 0)) Then
            ' 不在允许列表则跳过写入
            GoTo nextLoop
        End If
        ' 符合条件才写入Sheet1
        Sheet1.Cells(nextrow, "A").Value = diff
        nextrow = nextrow + 1
    End If
nextLoop:
Next i
  
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub

规则调整说明

直接修改代码开头ALLOWED_LOCATION常量的内容即可自定义过滤规则，多个允许的Location值用英文逗号分隔即可。

内容的提问来源于stack exchange，提问作者mjac