核心需求 #

• 仅对指定工作表生效，不影响工作簿其他工作表或新建Excel文档
• 保留填充拖拽柄显示，禁用拖拽填充功能，不通过Excel高级设置修改
• 用户拖拽填充时弹出提示该操作不被允许，并撤销填充数据
• 不影响单条/多条数据的删除、复制粘贴等操作

原有代码的问题 #

原代码通过Target.Cells.CountLarge > 1判断填充操作，会误触发批量粘贴、批量输入等合法操作，无法精准区分填充拖拽与其他操作。

修正后的完整代码 #

将代码放入目标工作表的专属模块中（而非标准模块）：

Option Explicit

Private originalSelection As Range ' 记录初始选中区域

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set originalSelection = Target ' 更新选中区域记录
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo exitsafe
    If Application.EnableEvents = False Then Exit Sub
    Application.EnableEvents = False

    ' --- 精准判断填充拖拽操作 ---
    Dim isDragFill As Boolean
    isDragFill = False
    
    ' 条件：1. 不是复制粘贴 2. 初始选中单个单元格 3. 变更区域大于1个单元格 4. 不是删除操作（变更区域不全为空）
    If Application.CutCopyMode = False Then
        If Not originalSelection Is Nothing And originalSelection.Cells.CountLarge = 1 Then
            If Target.Cells.CountLarge > 1 Then
                ' 判断是否为删除操作：检查目标区域是否全为空
                Dim cell As Range
                Dim allEmpty As Boolean
                allEmpty = True
                For Each cell In Target
                    If Not IsEmpty(cell.Value) Then
                        allEmpty = False
                        Exit For
                    End If
                Next cell
                If Not allEmpty Then
                    isDragFill = True
                End If
            End If
        End If
    End If
    
    ' 触发填充拖拽拦截
    If isDragFill Then
        Application.Undo
        MsgBox "该操作不被允许", vbExclamation
        GoTo exitsafe
    End If

    ' ===== 保留原有业务逻辑（请勿修改）=====
    Dim lastRow As Long
    Dim c As Range
    Dim rng As Range
    Dim rngRow As Range
    Dim modTime As String

    lastRow = Me.Cells(Me.Rows.Count, "B").End(xlUp).Row

    If Not Intersect(Target, Me.Cells(lastRow, "B")) Is Nothing Then
        Me.Unprotect Password:="#TPOzada@54EEcd#"
        Me.Range("BC1").Value = Now()
        Me.Protect Password:="#TPOzada@54EEcd#", UserInterfaceOnly:=True, AllowFiltering:=True
    End If

    For Each c In Target
        If HasValidationList(c) Then
            If Len(c.Value) > 0 Then
                If Not IsValidValue(c) Then
                    Application.Undo
                    MsgBox "Invalid entry in " & c.Address & _
                           ". Please select a value from the dropdown.", vbExclamation
                    GoTo exitsafe
                End If
            End If
        End If
        
        If Not Intersect(c, Me.Range("I:I,J:J,L:L,O:O")) Is Nothing Then
            If Len(c.Value) > 0 Then
                If Not IsNumeric(c.Value) Then
                    Application.Undo
                    MsgBox "Invalid numeric entry in " & c.Address & ". Only numbers are allowed.", vbExclamation
                    GoTo exitsafe
                End If
            End If
        End If
    Next c

    Set rng = Intersect(Target, Me.Range("A3:P999"))
    If Not rng Is Nothing Then
        modTime = Format(Now(), "dd/mm/yyyy")
        Me.Unprotect Password:="#TPOzada@54EEcd#"
        For Each rngRow In rng.Rows
            Me.Cells(rngRow.Row, "Q").Value = modTime
        Next rngRow
        Me.Protect Password:="#TPOzada@54EEcd#", UserInterfaceOnly:=True, AllowFiltering:=True
    End If

    Call RefreshPivotsAndSortBlanks

exitsafe:
    Application.EnableEvents = True
End Sub

' ===== 保留原有验证辅助函数（请勿修改）=====
Private Function HasValidationList(cell As Range) As Boolean
    On Error Resume Next
    HasValidationList = False
    If Not cell.Validation Is Nothing Then
        If cell.Validation.Type = xlValidateList Then HasValidationList = True
    End If
End Function

Private Function IsValidValue(cell As Range) As Boolean
    Dim f As String
    On Error Resume Next
    IsValidValue = True
    f = cell.Validation.Formula1
    If f <> "" Then
        IsValidValue = Not IsError(Application.Match(cell.Value, Evaluate(f), 0))
    End If
End Function

关键逻辑说明 #

1. 区域记录：通过Worksheet_SelectionChange记录每次选中的单元格范围，用于判断是否从单个单元格触发拖拽填充
2. 精准拦截：仅当同时满足以下条件时，判定为填充拖拽操作并拦截：
   • 未处于复制/粘贴状态（Application.CutCopyMode = False）
   • 初始选中单个单元格
   • 变更区域包含多个单元格
   • 变更区域不全为空（排除批量删除操作）
3. 作用范围：代码放在目标工作表模块中，仅对当前工作表生效，不影响其他工作表或新建文档
4. 保留原有功能：完整保留了用户原有的数据验证、修改时间记录、工作表保护、透视表刷新等业务逻辑

内容的提问来源于stack exchange，提问作者Ahmed Magdy Tpozada