☰

如何使此 VBA 代码仅与我的电子表格中的特定工作表相关？

tag-icon • tag-icon microsoft-excel vba range
如何使此 VBA 代码仅与我的电子表格中的特定工作表相关？

感谢 Contextures 的一段代码，我的电子表格现在允许在特定的下拉列表中进行多项选择；当您选择另一个值时，它会将其添加到单元格中的现有值中 - 如果您从下拉列表中再次选择单元格中列出的值，它会将其从单元格中的序列中删除。

该代码适用于我的电子表格中的两个工作表（好吧，可能适用于整个电子表格，但其他工作表没有下拉菜单），并且包含下拉菜单的列（范围）最初在两个工作表上位于同一列中。但是，由于其中一个工作表的格式发生了一些变化，带有下拉菜单的相关列现在在两个工作表的不同列中。

我又怎么能

  1. 修改以下代码以应用于工作表 A 中的 X 列和工作表 B 中的 Y 列，或者
  2. 将此代码两次应用于我的电子表格；一次用于工作表 A，一次用于工作表 B - 然后我可以保持代码原样，但更改给定工作表的列引用

我研究过如何设置工作表引用，但不了解如何将其嵌入到这段代码中。我还试图了解如何使一段 VBA 仅与一个工作表相关，但这让我更加困惑 - 我不知道如何将此更改应用于我当前的电子表格

答案1

您的范围由这行代码管理：

If Not Intersect(Target, Range("N:N")) Is Nothing Then

为了使其特定于工作表，您可以编写如下内容：

If (Not Intersect(Target, Worksheets("Sheet1").Range("N:N")) Is Nothing) 
    Or (Not Intersect(Target, Worksheets("Sheet2").Range("P:P")) Is Nothing) Then

答案2

您拥有的代码链接到工作表更改事件，并且必须位于与其相关的工作表的代码中。因此，将其复制到 Sheet1 代码（而不是模块）中，它将仅适用于 Sheet1。如果您将其放在工作簿代码页中，它可能适用于所有工作表。因此，将代码复制到特定工作表的代码中并修改范围以适应，如果您未在代码中指定工作表，它将默认在代码链接到的页面上运行。

答案3

多个工作表的工作表更改

标准模块例如Module1

Option Explicit

Sub ExpandDropDown(ByVal Target As Range, ByVal ColumnId As Variant)
    
    Dim ws As Worksheet
    Dim rngDV As Range
    Dim rngCol As Range
    Dim oldVal As String
    Dim newVal As String
    Dim lUsed As Long
    
    If Target.Cells.CountLarge > 1 Then Exit Sub ' multiple cells intersecting
    
    Set ws = Target.Worksheet
    On Error Resume Next
    Set rngDV = ws.Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo 0
    If rngDV Is Nothing Then Exit Sub ' no matching cells
    
    If Not Intersect(Target, rngDV) Is Nothing Then Exit Sub ' no intersection
    
    On Error Resume Next
    Set rngCol = ws.Columns(ColumnId)
    On Error GoTo 0
    If rngCol Is Nothing Then Exit Sub ' invalid 'ColumnId'
    
    Application.EnableEvents = False
    On Error GoTo ClearError
    
    ' Retrieve oldVal
    newVal = CStr(Target.Value)
    Application.Undo
    oldVal = CStr(Target.Value)
    Target.Value = newVal
    
    If Not Intersect(Target, rngCol) Is Nothing Then ' intersecting
        If oldVal <> "" Then
            If newVal <> "" Then
                lUsed = InStr(1, oldVal, newVal)
                If lUsed > 0 Then
                    If Right(oldVal, Len(newVal)) = newVal Then
                        Target.Value = Left(oldVal, Len(oldVal) _
                            - Len(newVal) - 2)
                    Else
                        Target.Value = Replace(oldVal, newVal & ", ", "")
                    End If
                Else
                    Target.Value = oldVal & ", " & newVal
                End If
            'Else ' do nothing because 'newVal = ""'
            End If
        ' Else ' do nothing because 'oldVal = ""'
        End If
    'Else ' do nothing because no intersection
    End If

SafeExit:
    Application.EnableEvents = True
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

任何工作表模块Sheet1，例如Sheet2...

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
     ExpandDropDown Target, "N" ' or 14, "X" or 24, "Y" or 25
End Sub

相关内容