Worksheet_SelectionChange中下拉多选代码失效问题求助（日历代码正常）

我将两段代码整合到Private Sub Worksheet_SelectionChange(ByVal Target As Range)中运行，其中日历弹窗功能正常，但下拉列表多选功能失效。单独运行多选代码时可正常执行，整合后的代码如下：

Private Sub Worksheet_Selection Change(ByVal Target As Range)
    Dim Cal As Shape
    On Error Resume Next
    Set Cal = Shapes("Calendar")
    On Error GoTo 0
    If Cal Is Nothing Then 'Shape Deleted
        Application.EnableEvents = False
         On Error Resume Next
        Application.Undo
        On Error GoTo 0
        Application.EnableEvents = True
    End If
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("S4,S6")) Is Nothing Then 'Change this to any cell (or cells) you would like to have the Pop-Up Calendar Appear
        CheckForSheet
        CalendarShow
     Else:
        CheckForSheet
        CalendarHide
    End If

Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.adress = "$t$2" Or Target.adress = "$u$2" Then
  If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
  Else: If Target.Value = "" Then GoTo Exitsub Else
    Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
      If Oldvalue = "" Then
        Target.Value = Newvalue
      Else
        If InStr(1, Oldvalue, Newvalue) = 0 Then
            Target.Value = Oldvalue & vbNewLine & Newvalue
      Else:
        Target.Value = Oldvalue
      End If
    End If
  End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True

End Sub

问题根源及修复方案 #

1. 拼写错误：代码中Target.adress是错误拼写，正确应为Target.Address；过程名Worksheet_Selection Change中间的空格需删除，改为Worksheet_SelectionChange。
2. 执行逻辑阻断：日历代码中的If Target.Count > 1 Then Exit Sub会直接终止过程，导致后面的多选代码无法执行，需调整逻辑顺序。
3. 事件状态管理混乱：多处重复设置Application.EnableEvents，易导致事件状态异常，需统一管理。

修复后的完整代码 #

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cal As Shape
    Dim Oldvalue As String
    Dim Newvalue As String
    
    ' 先处理下拉多选逻辑，避免被日历代码的Exit Sub阻断
    On Error GoTo Exitsub
    If Target.Count = 1 Then
        If Target.Address = "$T$2" Or Target.Address = "$U$2" Then
            ' 检查单元格是否存在数据验证
            On Error Resume Next
            Dim valCheck As Range
            Set valCheck = Target.SpecialCells(xlCellTypeAllValidation)
            On Error GoTo 0
            
            If Not valCheck Is Nothing Then
                If Target.Value <> "" Then
                    Application.EnableEvents = False
                    Newvalue = Target.Value
                    Application.Undo
                    Oldvalue = Target.Value
                    
                    If Oldvalue = "" Then
                        Target.Value = Newvalue
                    Else
                        ' 避免重复添加选项
                        If InStr(1, Oldvalue, Newvalue, vbTextCompare) = 0 Then
                            Target.Value = Oldvalue & vbNewLine & Newvalue
                        Else
                            Target.Value = Oldvalue
                        End If
                    End If
                End If
            End If
        End If
    End If
    
    ' 处理日历弹窗逻辑
    On Error Resume Next
    Set Cal = Shapes("Calendar")
    On Error GoTo 0
    
    If Cal Is Nothing Then
        Application.EnableEvents = False
        On Error Resume Next
        Application.Undo
        On Error GoTo 0
        Application.EnableEvents = True
    End If
    
    If Target.Count > 1 Then Exit Sub
    
    If Not Intersect(Target, Range("S4,S6")) Is Nothing Then
        CheckForSheet
        CalendarShow
    Else
        CheckForSheet
        CalendarHide
    End If

Exitsub:
    Application.EnableEvents = True ' 确保事件始终恢复启用状态
End Sub

关键修复说明 #

• 调整执行顺序：将多选逻辑移至日历代码的Exit Sub判断之前，保证单个单元格操作时多选代码能被执行。
• 修正拼写错误：修复Target.Address的拼写错误，确保单元格地址判断准确。
• 优化事件管理：统一在错误处理标签处恢复Application.EnableEvents，避免状态异常。
• 添加错误捕获：对SpecialCells操作添加错误处理，防止无数据验证时触发报错。

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