Excel/VBA：解决多数据验证区域阻止粘贴失效问题

Hey there! Let's break down what went wrong with your previous attempts and fix this properly.

First, let's recap your goal: you want to block users from pasting into multiple named ranges that have data validation, but exclude any alternating columns within those ranges that don't have validation.

What was wrong with your earlier code? #

1. Your first expanded code tried to create a Validationranges sub, but you couldn't reference that range in Worksheet_Change because it was a local variable inside the sub—Range("Validationranges") was looking for a named range (not your merged range), which didn't exist.
2. Your second simplified code just checked if the target was in the merged named ranges, but it didn't account for the alternating columns without validation, and it didn't verify if the paste actually broke existing validation.

Here's the fixed solution #

This code will:

• Target only the cells within your named ranges that have data validation (ignoring the alternating columns without it)
• Safely handle cases where a named range might be missing
• Prevent paste operations that would overwrite validated cells

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim validationAreas As Range
    Dim protectedCells As Range
    Dim cell As Range
    Dim intersectRange As Range
    
    ' Define all your named ranges that contain validated cells
    On Error Resume Next ' Handle missing named ranges gracefully
    Set validationAreas = Union( _
        Range("Amort"), _
        Range("Capacity"), _
        Range("ELV"), _
        Range("Level"), _
        Range("ProcGrp"), _
        Range("Region"), _
        Range("Section"), _
        Range("Tooling") _
    )
    On Error GoTo 0 ' Reset error handling
    
    ' Exit if no valid named ranges are found
    If validationAreas Is Nothing Then Exit Sub
    
    ' Collect ONLY the cells within those ranges that have data validation
    Set protectedCells = Nothing
    For Each cell In validationAreas
        If HasValidation(cell) Then
            If protectedCells Is Nothing Then
                Set protectedCells = cell
            Else
                Set protectedCells = Union(protectedCells, cell)
            End If
        End If
    Next cell
    
    ' Exit if no cells with validation exist in the named ranges
    If protectedCells Is Nothing Then Exit Sub
    
    ' Check if the user's edit/paste affects any protected cells
    Set intersectRange = Application.Intersect(Target, protectedCells)
    If intersectRange Is Nothing Then Exit Sub
    
    ' Undo the paste and show error message
    MsgBox "Error: You cannot paste data into these cells." & vbNewLine & _
           "Please use the drop-down to enter data instead.", vbCritical
    Application.EnableEvents = False ' Prevent loop from re-triggering Change event
    Application.Undo
    Application.EnableEvents = True ' Re-enable events
End Sub

Private Function HasValidation(r As Range) As Boolean
    ' Returns True if the specified cell has data validation
    On Error Resume Next
    Dim valType As XlDVType
    valType = r.Validation.Type
    HasValidation = (Err.Number = 0) ' No error means validation exists
    On Error GoTo 0 ' Reset error handling for future code
End Function

Key improvements explained: #

• Error handling for named ranges: The On Error Resume Next ensures your code doesn't crash if one of the named ranges is deleted or renamed.
• Targeted protection: We loop through all cells in your named ranges and only protect those that actually have data validation—this automatically excludes your alternating columns without validation.
• Safe undo: Disabling events before undoing prevents the Worksheet_Change event from firing again when we undo the paste.
• Precise intersection check: We only act if the user's edit touches a protected validated cell, not just any cell in the named ranges.

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