公式变更单元格值无法触发工作表取消隐藏及扩展需求问询

问题1：公式更新单元格值无法触发工作表显示/隐藏 #

现有worksheet_Change宏仅在手动编辑单元格时生效，当B2:B27区域的单元格通过公式计算改变值时，不会触发宏执行，导致对应工作表无法自动取消隐藏。

原因 #

Worksheet_Change事件仅响应手动编辑、粘贴或删除等用户直接操作导致的单元格内容变更，公式计算引发的单元格值变化不会触发该事件，需改用Worksheet_Calculate事件来捕获这类变化。

解决方案 #

添加Worksheet_Calculate事件，同时记录B2:B27区域的历史值，仅当值发生实际变化时执行工作表显示/隐藏逻辑，避免重复触发：

' 模块级变量，用于存储B2:B27的历史值
Private prevBValues As Variant

Private Sub Worksheet_Activate()
    ' 工作表激活时初始化历史值
    prevBValues = Range("B2:B27").Value
End Sub

Private Sub Worksheet_Calculate()
    Dim currBValues As Variant
    Dim i As Integer
    Dim wsName As String
    
    Application.ScreenUpdating = False
    currBValues = Range("B2:B27").Value
    
    ' 遍历B2:B27，对比历史值与当前值
    For i = 1 To UBound(currBValues, 1)
        If currBValues(i, 1) <> prevBValues(i, 1) Then
            wsName = Range("A2").Offset(i - 1, 0).Value ' 获取对应A列的工作表名
            If wsName <> "" Then
                On Error Resume Next
                ThisWorkbook.Sheets(wsName).Visible = (currBValues(i, 1) <> 0)
                If Err.Number = 9 Then
                    MsgBox "Sheet " & wsName & " is not present in this workbook."
                End If
                On Error GoTo 0
            End If
            ' 更新历史值
            prevBValues(i, 1) = currBValues(i, 1)
        End If
    Next i
    
    Application.ScreenUpdating = True
End Sub

' 保留原有的Worksheet_Change事件，处理手动编辑的情况
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False

    Dim cell As Range
    For Each cell In Target
        If Not Intersect(Range("B2:B27"), cell) Is Nothing Then
            Dim wsName As String
            wsName = cell.Offset(0, -1).Value
            If wsName <> "" Then
                On Error Resume Next
                ThisWorkbook.Sheets(wsName).Visible = (cell.Value <> 0)
                If Err.Number = 9 Then
                    MsgBox "Sheet " & wsName & " is not present in this workbook."
                End If
                On Error GoTo 0
                ' 更新历史值，避免Calculate事件重复处理
                prevBValues(cell.Row - 1, 1) = cell.Value
            End If
        End If
    Next cell

    Application.ScreenUpdating = True
End Sub

问题2：D2:D27区域值变化时取消隐藏"PCL"工作表 #

可以实现，需同时覆盖手动编辑和公式计算两种场景，以下是整合后的处理逻辑：

解决方案 #

在现有事件中添加D列的处理逻辑：

1. 在Worksheet_Change中处理手动编辑场景：
   在原循环内添加D列判断：

' 在Worksheet_Change的For Each循环内添加
If Not Intersect(Range("D2:D27"), cell) Is Nothing Then
    ' 只要D2:D27任一单元格值变化，就取消隐藏"PCL"工作表
    On Error Resume Next
    ThisWorkbook.Sheets("PCL").Visible = xlSheetVisible
    If Err.Number = 9 Then
        MsgBox "Sheet PCL is not present in this workbook."
    End If
    On Error GoTo 0
End If

2. 在Worksheet_Calculate中处理公式计算场景：

• 先添加模块级变量存储D列历史值：

Private prevDValues As Variant

• 在Worksheet_Activate中初始化D列历史值：

prevDValues = Range("D2:D27").Value

• 在Worksheet_Calculate中添加D列值对比逻辑：

' 在Worksheet_Calculate开头添加
Dim currDValues As Variant
currDValues = Range("D2:D27").Value

' 在B列处理循环后添加D列处理
For i = 1 To UBound(currDValues, 1)
    If currDValues(i, 1) <> prevDValues(i, 1) Then
        On Error Resume Next
        ThisWorkbook.Sheets("PCL").Visible = xlSheetVisible
        If Err.Number = 9 Then
            MsgBox "Sheet PCL is not present in this workbook."
        End If
        On Error GoTo 0
        ' 更新D列历史值
        prevDValues(i, 1) = currDValues(i, 1)
        Exit For ' 仅触发一次，若需每次变化都触发可删除此行
    End If
Next i

完整整合后的代码 #

' 模块级变量，存储历史值
Private prevBValues As Variant
Private prevDValues As Variant

Private Sub Worksheet_Activate()
    ' 初始化历史值
    prevBValues = Range("B2:B27").Value
    prevDValues = Range("D2:D27").Value
End Sub

Private Sub Worksheet_Calculate()
    Dim currBValues As Variant, currDValues As Variant
    Dim i As Integer
    Dim wsName As String
    
    Application.ScreenUpdating = False
    currBValues = Range("B2:B27").Value
    currDValues = Range("D2:D27").Value
    
    ' 处理B列公式变化
    For i = 1 To UBound(currBValues, 1)
        If currBValues(i, 1) <> prevBValues(i, 1) Then
            wsName = Range("A2").Offset(i - 1, 0).Value
            If wsName <> "" Then
                On Error Resume Next
                ThisWorkbook.Sheets(wsName).Visible = (currBValues(i, 1) <> 0)
                If Err.Number = 9 Then
                    MsgBox "Sheet " & wsName & " is not present in this workbook."
                End If
                On Error GoTo 0
            End If
            prevBValues(i, 1) = currBValues(i, 1)
        End If
    Next i
    
    ' 处理D列公式变化
    For i = 1 To UBound(currDValues, 1)
        If currDValues(i, 1) <> prevDValues(i, 1) Then
            On Error Resume Next
            ThisWorkbook.Sheets("PCL").Visible = xlSheetVisible
            If Err.Number = 9 Then
                MsgBox "Sheet PCL is not present in this workbook."
            End If
            On Error GoTo 0
            prevDValues(i, 1) = currDValues(i, 1)
            Exit For ' 仅触发一次，若需每次变化都触发可删除此行
        End If
    Next i
    
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False

    Dim cell As Range
    For Each cell In Target
        ' 处理B列手动编辑
        If Not Intersect(Range("B2:B27"), cell) Is Nothing Then
            Dim wsName As String
            wsName = cell.Offset(0, -1).Value
            If wsName <> "" Then
                On Error Resume Next
                ThisWorkbook.Sheets(wsName).Visible = (cell.Value <> 0)
                If Err.Number = 9 Then
                    MsgBox "Sheet " & wsName & " is not present in this workbook."
                End If
                On Error GoTo 0
                prevBValues(cell.Row - 1, 1) = cell.Value
            End If
        End If
        
        ' 处理D列手动编辑
        If Not Intersect(Range("D2:D27"), cell) Is Nothing Then
            On Error Resume Next
            ThisWorkbook.Sheets("PCL").Visible = xlSheetVisible
            If Err.Number = 9 Then
                MsgBox "Sheet PCL is not present in this workbook."
            End If
            On Error GoTo 0
            prevDValues(cell.Row - 1, 1) = cell.Value
        End If
    Next cell

    Application.ScreenUpdating = True
End Sub

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