已分配Excel VBA工作表更改事件

Question

使用Excel 2007，我了解我可以在它创建的工作表上创建worksheet_change事件。

但是如何将全局子更改事件分配给新创建的工作表？

e.g。

Public Sub DataChange(ByVal Target As Range)
  ' this will check and see if the user or operator has change the column field
  ' if they fill in "X", mark the whole row to red color
  ' otherwise leave it black
  Dim KeyCells As Range
  Dim LastRow As Long
  LastRow = Cells(Rows.Count, 1).END(xlUp).Row
  Set KeyCells = Range("L2:L" & LastRow)

  If Not Application.Intersect(KeyCells, Range(Target.Address)) _
    Is Nothing Then
    If Target.Value = "X" Or Target.Value = "x" Then
        Target.EntireRow.Font.color = vbRed
    Else
        Target.EntireRow.Font.color = vbBlack
    End If
  End If
End Sub

然后在Module1的单独子程序中......

Public Sub CreateWorkSheet() 
  Dim ws As Worksheet

  Set ws = Sheets.Add
  ws.Name = "Test1"
  ' Here where I want to set the event but I do not know the syntax
  ' ws.OnChange = DataChange

  Debug.Print "Done"

End Sub 

我曾经在创建控件（C＃/ WPF / Pascal）时动态分配事件，所以我想在Excel世界中会有一个。任何建议或帮助将不胜感激。

Answer 1

我会去找@ Jeeped的最后一个建议

将此代码放在ThisWorkbook代码窗格

中

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    DataChange Target ' this sub will be called at any change of any worksheet passing the chenged range
End Sub

然后将其放在相同的代码窗格或任何其他模块中

Public Sub DataChange(ByVal Target As Range)
  ' this will check and see if the user or operator has change the column field
  ' if they fill in "X", mark the whole row to red color
  ' otherwise leave it black
  Dim KeyCells As Range
  Set KeyCells = Range("L2:L" & Cells(Rows.Count, 1).End(xlUp).Row)

  If Not Application.Intersect(KeyCells, Target) Is Nothing Then Target.EntireRow.Font.color = IIf(UCase(Target.Value2) = "X", vbRed, vbBlack)
End Sub

Answer 2

正如Jeeped所提到的，最简单的方法可能是复制已经有Private Sub Worksheet_Change代码的工作表，但如果您将以下代码放在ThisWorkbook下，还有另一种方法，每当创建一个新工作表时，它将在其后面添加所需的代码：

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Dim NewSheet As Worksheet
    Set NewSheet = Sheets(ActiveSheet.Name)
    Code = "Private Sub Worksheet_Change(ByVal Target As Range)" & vbCrLf
    Code = Code & "MsgBox ""your code here""" & vbCrLf
    Code = Code & "End Sub"
    With ThisWorkbook.VBProject.VBComponents(NewSheet.Name).CodeModule
    NextLine = .CountOfLines + 1
    .InsertLines NextLine, Code
    End With
End Sub

这里的缺点是需要通过点击Trust access to the VBA project object model来更改宏的信任设置：

修改

您还可以使用类似的方法将代码从一个工作表复制到另一个工作表：

Sub test()
Dim CodeCopy As VBIDE.CodeModule
Dim CodePaste As VBIDE.CodeModule
Dim numLines As Long

Set CodeCopy = ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
Set CodePaste = ActiveWorkbook.VBProject.VBComponents("Sheet2").CodeModule

numLines = CodeCopy.CountOfLines
'Use this line to erase all code that might already be in sheet2
'If CodePaste.CountOfLines > 1 Then CodePaste.DeleteLines 1, CodePaste.CountOfLines

CodePaste.AddFromString CodeCopy.Lines(1, numLines)
End Sub