如何实现修改D列下拉列表时自动运行指定VBA代码？

核心问题修正 #

原代码存在两个关键问题导致无法自动触发：

• 错误嵌套了两个Sub过程，事件过程未正确闭合
• 使用了选中单元格触发的Worksheet_SelectionChange事件，而非修改内容触发的Worksheet_Change事件

修改后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅当修改的是D列单元格时执行后续逻辑
    If Not Intersect(Target, Columns("D")) Is Nothing Then
        FilterAndCopy
    End If
End Sub

Sub FilterAndCopy()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Dim lngLastRow As Long
    Dim ActiveSheet As Worksheet, InactiveSheet As Worksheet, PendingSheet As Worksheet
    Dim RenewedSheet As Worksheet, FollowUpSheet As Worksheet, RedZoneSheet As Worksheet

    Set ActiveSheet = Sheets("Active")
    Set InactiveSheet = Sheets("Inactive")
    Set PendingSheet = Sheets("Pending")
    Set RenewedSheet = Sheets("Renewed")
    Set FollowUpSheet = Sheets("Follow Up")
    Set RedZoneSheet = Sheets("Red Zone")

    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

    With Range("A1", "R" & lngLastRow)
        .AutoFilter
        .AutoFilter Field:=4, Criteria1:="Active"
        .Copy ActiveSheet.Range("A1")
        .AutoFilter Field:=4, Criteria1:="Inactive"
        .Copy InactiveSheet.Range("A1")
        .AutoFilter Field:=4, Criteria1:="Pending"
        .Copy PendingSheet.Range("A1")
        .AutoFilter Field:=4, Criteria1:="Renewed"
        .Copy RenewedSheet.Range("A1")
        .AutoFilter Field:=4, Criteria1:="Follow Up"
        .Copy FollowUpSheet.Range("A1")
        .AutoFilter Field:=4, Criteria1:="Red Zone"
        .Copy RedZoneSheet.Range("A1")
        .AutoFilter
    End With

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

关键说明 #

1. 事件触发逻辑：Worksheet_Change事件会在单元格内容修改后触发，加上Intersect判断，只在修改D列时执行复制，避免无关操作触发代码
2. 代码放置位置：必须将这段代码粘贴到存放原始数据的工作表的代码模块中（右键工作表标签→「查看代码」→粘贴代码），不能放在标准模块里
3. 性能优化：保留了原代码中关闭屏幕更新、禁用事件、手动计算的逻辑，避免执行过程中卡顿或触发重复事件

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