VBA Excel 运行- 更改命名范围外的单元格时出现错误“1004”

Question

用例：我需要实现一个基于命名范围的多 select 下拉菜单。我在多个工作表中定义了命名范围。我认为下面的代码只在使用“水果”的单元格中工作时执行。但是，每当我尝试更改任何页面上的任何单元格时，我都会收到以下错误：

运行-时间错误'1004'：应用程序定义或对象定义的错误调试器在第 10 行打开，当我将鼠标悬停在目标上时，它会显示我要添加到不属于“Fruits”范围的单元格的任何文本。

    If Not Intersect(Target, Sh.Range("HVA_Range")) Is Nothing Then

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim OldVal As String
    Dim NewVal As String

    ' If more than 1 cell is being changed
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    If Not Intersect(Target, Sh.Range("Fruits")) Is Nothing Then
        ' Turn off events so our changes don't trigger this event again
        Application.EnableEvents = False
        NewVal = Target.Value
        
        ' If there's nothing to undo this will cause an error
        On Error Resume Next
        Application.Undo
        On Error GoTo 0
        OldVal = Target.Value
        
        ' If selection is already in the cell we want to remove it
        If InStr(OldVal, NewVal) Then
            'If there's a comma in the cell, there's more than one word in the cell
            If InStr(OldVal, ",") Then
                If InStr(OldVal, ", " & NewVal) Then
                    Target.Value = Replace(OldVal, ", " & NewVal, "")
                Else
                    Target.Value = Replace(OldVal, NewVal & ", ", "")
                End If
            Else
                ' If we get to here the selection was the only thing in the cell
                Target.Value = ""
            End If
        Else
            If OldVal = "" Then
                Target.Value = NewVal
            Else
                ' Delete cell contents
                If NewVal = "" Then
                    Target.Value = NewVal
                Else
                    ' This IF prevents the same value appearing in the cell multiple times
                    ' If you are happy to have the same value multiple times remove this IF
                    If InStr(Target.Value, NewVal) = 0 Then
                        Target.Value = OldVal & ", " & NewVal
                    End If
                End If
            End If
        End If
        
        Application.EnableEvents = True
    Else
        Exit Sub
    End If
End Sub

当我在 Fruits 命名范围中使用 make changes 时，它似乎工作正常。

Answer 1

正如您所观察到的，当处理 sheet 没有命名范围时会发生此错误。

您需要检测名称的缺失，然后中止

在 If Not Intersect ... 行之前添加这个

Dim nm as Name
On Error Resume Next
Set nm = Sh.Names("Fruits")
On Error GoTo 0
If nm Is Nothing Then Exit Sub

此代码中还有许多其他 issues/opertunities 可以解决

陷阱错误是改的sheet不是作品sheet
如果更改了多个单元格，而不是退出处理每个单元格
允许用户输入多个逗号分隔的项目，处理每个项目
允许用户在逗号后省略或输入多个空格。原样在术语中保留多个空格。
我已经使用 TextJoin 重建分隔列表。如果你的 Excel 版本不支持，可以用另一种方式完成（参见注释掉的替代方法）

我已经包含了一个 UpdateCell 定义更新单元格规则的子项。如果我的解释不符合你的，请告诉我。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    ' To allow multiple selections in a Drop Down List in Excel (without repetition)
    Dim ws As Worksheet
    Dim nm As Name
    Dim OldValue As Variant
    Dim NewValue As Variant
    Dim rChanged As Range
    Dim TargetArea As Range
    Dim TargetAreaVal As Range
    Dim a As Long
    Dim r As Long
    Dim c As Long
    Dim i As Long
    Dim n As Long
    Dim NamedRange As String
    
    NamedRange = "Fruits" ' change to suit your needs
    
    ' Check for Changes we don't want to process
    '   Sh is not a Worksheet
    On Error Resume Next
        Set ws = Sh
        If ws Is Nothing Then Exit Sub
    
    '   No Named range on sheet
        Set nm = ws.Names(NamedRange)
        If nm Is Nothing Then Exit Sub
    
    ' Use handler to ensure Events are turned back on
    On Error GoTo EH
    Set rChanged = Application.Intersect(Target, nm.RefersToRange)

    If Not rChanged Is Nothing Then
        Application.EnableEvents = False
        ' Use Jagged Arrays to allow for non-contiguous ranges
        ReDim NewValue(1 To Target.Areas.Count)
        ReDim OldValue(1 To Target.Areas.Count)
        
        For a = 1 To Target.Areas.Count
            NewValue(a) = Target.Areas(a).Value2
        Next
        
        Application.Undo
        For a = 1 To Target.Areas.Count
            OldValue(a) = Target.Areas(a).Value2
        Next
        Application.Undo ' restores original state
        
        ' For each non-contiguous range
        For a = 1 To UBound(NewValue)
            n = 0
            On Error Resume Next
               n = UBound(NewValue(a), 1)
            On Error GoTo EH
            Set TargetArea = rChanged.Areas(a).Cells
            If n = 0 Then
                ' Single Cell in Area
                UpdateCell TargetArea, OldValue(a), NewValue(a)
            Else
                ' Multiple Cells in Area
                For r = 1 To UBound(NewValue(a), 1)
                    For c = 1 To UBound(NewValue(a), 2)
                        UpdateCell TargetArea.Cells(r, c), OldValue(a)(r, c), NewValue(a)(r, c)
                    Next
                Next
            End If
        Next
    End If
EH:
    Application.EnableEvents = True

End Sub


Private Sub UpdateCell(ByVal cl As Range, OldValue As Variant, NewValue As Variant)
    ' Update rules, in priority order
    ' 1.  NewValue is Blank - delete contents (leave cell as it is)
    ' 2.  NewValue contains commas - loop each value
    ' 3.  OldValue contains NewValue - remove it
    ' 4.  Else, Add NewValue to OldValue
    
    Dim OldValues() As String
    Dim NewValues() As String
    Dim i As Long
    
    If NewValue = vbNullString Then
        '1. do nothing
    Else
        '   Account for possibility user doesnt include a space after the comma, or includes several spaces
        Do While NewValue Like "*, *"
            NewValue = Replace$(NewValue, ", ", ",")
        Loop
        Do While OldValue Like "*, *"
            OldValue = Replace$(OldValue, ", ", ",")
        Loop
        
        OldValues = Split(OldValue, ",")
        NewValues = Split(NewValue, ",")
        If LBound(NewValues) < UBound(NewValues) Then
            ' Multiple NewValue
            For i = LBound(NewValues) To UBound(NewValues)
                '2. Loop for each NewValue
                UpdateCell cl, OldValue, NewValues(i)
            Next
        Else
            ' Single NewValue
            For i = LBound(OldValues) To UBound(OldValues)
                If OldValues(i) = NewValue Then
                    ' 3. remove it
                    OldValues(i) = vbNullString
                    Exit For
                End If
            Next
            If i > UBound(OldValues) Then
                ' 4. Wasn't found, add it
                ReDim Preserve OldValues(LBound(OldValues) To UBound(OldValues) + 1)
                OldValues(UBound(OldValues)) = NewValue
            End If
            ' Rebuild Value
            OldValue = Application.TextJoin(",", True, OldValues)

            ' Alternative if TextJoin isnt available
'            OldValue = Join(OldValues, ",")
'            Do While OldValue Like "*,,*"
'                OldValue = Replace$(OldValue, ",,", ",")
'            Loop
'            If OldValue Like ",*" Then OldValue = Mid$(OldValue, 2)
'            If OldValue Like "*," Then OldValue = Left$(OldValue, Len(OldValue) - 1)
            

            ' restore spaces after commas
            cl.Value2 = Replace$(OldValue, ",", ", ")
        End If
    End If
    

End Sub

VBA Excel 运行- 更改命名范围外的单元格时出现错误“1004”

VBA Excel Run-time error '1004' on changes to cells outside of Named Range

excel

vba

multi-select

drop-down-menu