将工作表 VBA 转换为所有工作表

Question

我正在尝试获取一些在单个 sheet 上运行的代码并将其转换为适用于本书中的所有作品sheet。我想我可以将代码移动到一个模块，然后使用中描述的 Workbook_SheetChange“包装器”。但是，Multiple Select 下拉列表仍然只适用于原始 sheet，尽管在所有 sheet 上都定义了“Named_Range”。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    With Sh
        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, ActiveSheet.Range("Named_Range")) 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 = ""
                    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 With
End Sub

Answer 1

常规模块没有事件。他们与主机无关。 SheetChange 事件在工作簿对象中。所以这意味着您必须将代码放入 ThisWorkBook 对象。

现在查看您的代码，我看到一个 With Sh 块什么都不做。你永远不会使用那个对象。使用 sheet 对象唯一有意义的地方是你引用 ActiveSheet 的地方。我们总是想使用 Sh 并且我们永远不想假设正确的 sheet 是活动的。

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("Named_Range")) 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

最后，您的 if 树底部存在逻辑缺陷。如果 oldval 不在 newval 中，则 oldval 不为空且 new val 不为空，您最终会在最后一个地方添加一个逗号。如果不需要，那么您处于更改运行 .Undo 并且根本没有设置 Target.Value 的状态。这可能会使您无法将单元格的内容更改为新值。我不确定您是否有意这样做。

将工作表 VBA 转换为所有工作表

Converting Worksheet VBA to all Sheets

excel

vba

module