VBA在其他课程上的筹款活动

我正在尝试实施this post in codereview的建议

目标:

管理当用户与Excel表(ListObjects)交互时会发生什么

最后的想法是为不同的表提供定制事件。例如在table1中添加一行时,将引发自定义AddEvent1,而在table2中进行此操作时,将引发AddEvent2。

只有一个类可以管理事件,而一个类可以保存表及其信息。


因此建议的过程是:

  1. 将列表对象添加到名为Table的类中
  2. 该类将侦听父表(ChangeSelectionChange)上的事件
  3. 当触发更改事件时,从处理这些事件的类TableManager触发一个自定义事件(诸如addingupdatingdeleting行之类的事件)

编辑#1:

调整代码:

  • Create函数现在返回Table的实例
  • 属性Set Sourcetable现在将listObjectParentSheet字段设置为相应的值

但是Table Manager仍然没有收听listObjectParentSheet_Change引发的事件


组件:

1)带有Excel表(ListObject)的工作表,其后包含以下代码:

Private Sub Worksheet_activate()

    Dim myTable As Table
    Dim myTableManager As TableManager

    Set myTable = Table.Create(Me.ListObjects(1))

    Set myTableManager = New TableManager

    Set myTableManager.TableInstance = myTable

End Sub

2)类Table(使用rubberduck的ID设置为true)

'@Folder("VBAProject")

Option Explicit
'@PredeclaredId

Private Type TTable
    Sourcetable As ListObject
End Type

Private this As TTable

Private WithEvents listObjectParentSheet As Excel.Worksheet

Public Event AddEvent()

Public Property Get Sourcetable() As ListObject
    Set Sourcetable = this.Sourcetable
End Property

Public Property Set Sourcetable(ByVal value As ListObject)
    Set this.Sourcetable = value
    Set listObjectParentSheet = value.Parent
End Property

Public Property Get Self() As Table
    Set Self = Me
End Property

Public Function Create(ByVal EvalSourcetable As ListObject) As Table
    With New Table
        Set .Sourcetable = EvalSourcetable
        Set Create = .Self
    End With
End Function

Private Sub listObjectParentSheet_Change(ByVal Target As Range)
    If Not Intersect(Target,Sourcetable.DataBodyRange) Is Nothing Then
        MsgBox listObjectParentSheet.Name & " " & Target.Address
        RaiseEvent AddEvent
    End If
End Sub

3)类TableManager

Option Explicit

Private WithEvents m_table As Table

Public Property Get TableInstance() As Table
    Set TableInstance = m_table
End Property

Public Property Set TableInstance(ByRef tableObject As Table)
    Set m_table = tableObject
End Property

Private Sub m_table_AddEvent()
    MsgBox "Adding something"
End Sub

问题/问题:

我还没有弄清楚如何在TableManager类中触发“ AddEvent”。我知道我搞砸了一些实例化类的概念,但是我不知道自己在做什么错。


预期结果:

当用户更改列表对象的任何单元格时,在抬起AddEvent时显示消息框“添加内容”


任何帮助将不胜感激。

编辑#2

最终代码要感谢Mat的回答:

表格:Sheet1

Private Sub Worksheet_activate()
    With TableManager
        Set .TableEvents = Table.Create(Sheet1.ListObjects(1))
    End With
End Sub

模块:ListObjectUtilities

Option Explicit

Public Function getcellRow(ByVal EvalTable As ListObject,ByVal EvalCell As Range) As Long

    If Intersect(EvalCell,EvalTable.DataBodyRange) Is Nothing Then Exit Function

    getcellRow = EvalCell.Row - EvalTable.HeaderRowRange.Row

End Function

Public Function getcellColumn(ByVal EvalTable As ListObject,EvalTable.DataBodyRange) Is Nothing Then Exit Function

    getcellColumn = EvalCell.Column - EvalTable.HeaderRowRange.Column + 1

End Function

班级:ITable

Option Explicit

Public Property Get Sourcetable() As ListObject
End Property

班级:Table

'@Folder("VBAProject")
'@PredeclaredId
Option Explicit

Private WithEvents TableSheet As Excel.Worksheet

Private Type TTable
    Sourcetable As ListObject
    LastRowCount As Long
    LastColumnCount As Long
End Type

Private this As TTable

Public Event Changed(ByVal cell As Range)
Public Event AddedNewRow(ByVal newRow As ListRow)
Public Event AddedNewColumn(ByVal newColumn As ListColumn)

Implements ITable

Public Function Create(ByVal Source As ListObject) As ITable
    With New Table
        Set .Sourcetable = Source
        Set Create = .Self
    End With
End Function

Public Property Get Self() As Table
    Set Self = Me
End Property

Public Property Get Sourcetable() As ListObject
    Set Sourcetable = this.Sourcetable
End Property

Public Property Set Sourcetable(ByVal value As ListObject)
    ThrowIfSet this.Sourcetable
    ThrowIfNothing value
    Set TableSheet = value.Parent
    Set this.Sourcetable = value
    Resize
End Property

Friend Sub OnChanged(ByVal Target As Range)
    RaiseEvent Changed(Target)
End Sub

Friend Sub OnAddedNewRow(ByVal newRow As ListRow)
    RaiseEvent AddedNewRow(newRow)
End Sub

Friend Sub OnAddedNewColumn(ByVal newColumn As ListColumn)
    RaiseEvent AddedNewColumn(newColumn)
End Sub

Private Sub ThrowIfNothing(ByVal Target As Object)
    If Target Is Nothing Then Err.Raise 5,TypeName(Me),"Argument cannot be a null reference."
End Sub

Private Sub ThrowIfSet(ByVal Target As Object)
    If Not Target Is Nothing Then Err.Raise 5,"This reference is already set."
End Sub

Private Sub Resize()
    With this.Sourcetable
        this.LastRowCount = .ListRows.Count
        this.LastColumnCount = .ListColumns.Count
    End With
End Sub

Private Sub TableSheet_Change(ByVal Target As Range)

    If Intersect(Target,Sourcetable.DataBodyRange) Is Nothing Then Exit Sub

    Select Case True
    Case this.Sourcetable.DataBodyRange.Columns.Count > this.LastColumnCount
        OnAddedNewColumn Sourcetable.ListColumns(ListObjectUtilities.getcellColumn(this.Sourcetable,Target))
    Case this.Sourcetable.DataBodyRange.Rows.Count > this.LastRowCount
        OnAddedNewRow Sourcetable.ListRows(ListObjectUtilities.getcellRow(this.Sourcetable,Target))
    Case Else
        OnChanged Target
    End Select
    Resize
End Sub

Private Property Get ITable_Sourcetable() As ListObject
    Set ITable_Sourcetable = this.Sourcetable
End Property

班级:TableManager

'@Folder("VBAProject")
'@PredeclaredId
Option Explicit
Private WithEvents MyTable As Table

Public Property Get TableEvents() As Table
    Set TableEvents = MyTable
End Property

Public Property Set TableEvents(ByVal value As Table)
    Set MyTable = value
End Property

Private Sub MyTable_AddedNewColumn(ByVal newColumn As ListColumn)
    MsgBox "Added new column " & newColumn.Range.Column
End Sub

Private Sub MyTable_AddedNewRow(ByVal newRow As ListRow)
    MsgBox "Added new row " & newRow.Range.Row
End Sub

Private Sub MyTable_Changed(ByVal cell As Range)
    MsgBox "Changed " & cell.Address
End Sub

Sample file

yiqwer 回答:VBA在其他课程上的筹款活动

我尝试进行复制,但随后发现依靠Worksheet.Activate注册处理程序会导致行为异常:有时您需要“摆动”工作表以使其保持正常状态,尤其是在编辑代码时。可能只是:)

请注意,为了能够触发AddedNewRowAddedNewColumn甚至RemovedRowRemovedColumn,您需要不断跟踪表格的大小Worksheet.ChangeWorksheet.SelectionChange处理程序的组合。

表格类模块:

'@Folder("VBAProject")
'@PredeclaredId
Option Explicit

Private WithEvents TableSheet As Excel.Worksheet

Private Type TTable
    SourceTable As ListObject
    LastRowCount As Long
    LastColumnCount As Long
End Type

Private this As TTable

Public Event Changed(ByVal cell As Range)
Public Event AddedNewRow(ByVal newRow As ListRow)
Public Event AddedNewColumn(ByVal newColumn As ListColumn)

Public Function Create(ByVal Source As ListObject) As Table
    With New Table
        Set .SourceTable = Source
        Set Create = .Self
    End With
End Function

Public Property Get Self() As Table
    Set Self = Me
End Property

Public Property Get SourceTable() As ListObject
    Set SourceTable = this.SourceTable
End Property

Public Property Set SourceTable(ByVal Value As ListObject)
    ThrowIfSet this.SourceTable
    ThrowIfNothing Value
    Set TableSheet = Value.Parent
    Set this.SourceTable = Value
    Resize
End Property

Friend Sub OnChanged(ByVal Target As Range)
    RaiseEvent Changed(Target)
End Sub

Friend Sub OnAddedNewRow(ByVal newRow As ListRow)
    RaiseEvent AddedNewRow(newRow)
End Sub

Friend Sub OnAddedNewColumn(ByVal newColumn As ListColumn)
    RaiseEvent AddedNewColumn(newColumn)
End Sub

Private Sub ThrowIfNothing(ByVal Target As Object)
    If Target Is Nothing Then Err.Raise 5,TypeName(Me),"Argument cannot be a null reference."
End Sub

Private Sub ThrowIfSet(ByVal Target As Object)
    If Not Target Is Nothing Then Err.Raise 5,"This reference is already set."
End Sub

Private Sub Resize()
    With this.SourceTable
        this.LastRowCount = .ListRows.Count
        this.LastColumnCount = .ListColumns.Count
    End With
End Sub

Private Sub TableSheet_Change(ByVal Target As Range)
    If Not (Target.ListObject Is SourceTable) Then Exit Sub
    OnChanged Target
    Resize
End Sub

请注意,您可以使用Is运算符来确定Target.ListObject是否与SourceTable引用相同的对象,而不是将Application.Intersect用于范围:

If Not (Target.ListObject Is SourceTable) Then Exit Sub

从那里开始,我们需要一个类来处理此Changed事件-我将其放在此处的Sheet1代码中,但是任何类模块都可以(包括{{1 }}模块):

Sheet1 工作表模块:

UserForm

'@Folder("VBAProject") Option Explicit Private WithEvents MyTable As Table Public Property Get TableEvents() As Table Set TableEvents = MyTable End Property Public Property Set TableEvents(ByVal value As Table) Set MyTable = value End Property Private Sub MyTable_Changed(ByVal cell As Range) MsgBox "Changed " & cell.Address End Sub 引用仍然需要放在Table某个地方-在主机工作簿的Set处理程序中:

此工作簿工作簿模块:

Open

下一步是清理'@Folder("VBAProject") Option Explicit Private Sub Workbook_Open() With Sheet1 Set .TableEvents = Table.Create(.ListObjects(1)) End With End Sub 返回的公共接口-就目前而言,情况非常混乱,Table.Create接口有点肿:​​p>

Public and Friend members of the Table interface

所有这些成员都将对Table可用,除非我们执行某些操作。如果我们只能公开客户代码确实所需的成员,怎么办?

Only the SourceTable member is listed for the object returned by Table.Create

使用Rubberduck,可以通过右键单击Sheet1.TableEvents类中的任意位置并从“重构”菜单中选择“提取接口”,来提取接口。要提取的成员-这里是Table获取方法(我们不会公开设置方法!):

Rubberduck's Extract Method refactoring

这将创建一个新的私有类(在将来的版本中会更改)-如果接口是从公共类中提取出来的,则在 properties 工具窗口(F4)中将其设置为SourceTable

重构将在PublicNotCreatable类的顶部添加Implements ITable(假设您没有重命名接口),并将添加该成员:

Table

您需要做的就是提供实现:

Private Property Get ITable_SourceTable() As ListObject
    Err.Raise 5 'TODO implement interface member
End Property

现在Private Property Get ITable_SourceTable() As ListObject Set ITable_SourceTable = this.SourceTable End Property 可以返回Table.Create抽象:

ITable
本文链接:https://www.f2er.com/2801277.html

大家都在问