4
\$\begingroup\$

Objective:

Manage what happens when users interact with Excel Tables (ListObjects)


Possible interactions:

  • Update an existing Excel table
    • Add rows/columns to the table
    • Update a cell or a range of cells
    • Delete rows/columns to the table
    • Add a new Excel table
  • Delete an Excel table
  • Add a new Excel table

Specifications:

  • Actions that are executed depend on the sheet that the table (ListObject) is located, i.e., if table is located in sheet x the Action that is executed should be generic action and if table is located in sheet y the Action that is executed should be create a task
  • Actions depend on what is happening with the table, i.e., there should be an Action for the event of Adding rows and a different one for Deleting rows
  • Actions should know what triggered them, e.g., Sheet, Table and Cell
  • If user adds a new Table to a Sheet it should also respond to the Actions performed in it's cells

Code design standards:

  • Use classes
  • Use interfaces
  • Implement strategy patterns
  • Implement factory patterns <- This one I still don't understand quite well how to apply the concept

  • Implement Unit tests <- This one I'm far from understanding


Sample use case #1:

  • User modifies a cell or a range inside an Excel Table
    • Directly edit a cell
    • Copy paste a cell or a range
    • Use autofill from a cell and copy it to the next one (this couldn't find how to respond)
  • An action is executed:
    • Program displays what was the previous value and the new value in the modified cell

Sample use case #2:

  • User adds a new Excel Table (ListObject) to SheetY
  • User modifies a cell in the new Excel Table
  • An action is executed:
    • Program displays what was the previous value and the new value in the modified cell

Sample use case #3:

  • User deletes an Excel Table (ListObject) from SheetY
  • User modifies a cell in another Excel Table
  • An action is executed:
    • Program displays what was the previous value and the new value in the modified cell

Would appreciate your review to find out:

  1. If code design expectations are correctly implemented
  2. How to implement a factory pattern (if it's useful in this case)
  3. How to implement unit tests
  4. If this approach is efficient (e.g. the way I'm handling how to store the table range previous values)
  5. Any other insight you may consider

Reference


Current file

You can download the demo file from here

File structure:

File structure

  • SheetX contains a table (ListObject) called TableX
  • SheetY contains two tables (ListObjects) called TableY1 and TableY2

Code

Code has annotations from Rubberduck add-in

If you don't have Rubberduck installed you can:

  • Go and download it now...this is a must when you're developing in VBA!...and follow these instructions - Special thanks to Mathieu and his team ;)
  • You must follow these instructions to set the predeclared attribute to true in the corresponding classes (look for "where to put it" in the article)

Rubberduck code explorer view

Components

Sheet: SheetX

'@Version(1)
'@Folder("App.TableTest")

Option Explicit

' Copywrite (C) 2019 Ricardo Diaz
' This file is distributed under the GPL-3.0 license
' Obtain a copy of the GPL-3.0 license <http://opensource.org/licenses/GPL-3.0>

Private newAppTables As ITables

Private Sub Worksheet_Activate()
    InitializeTablesGeneric
End Sub

Private Sub Worksheet_Deactivate()
    If Not newAppTables Is Nothing Then
        newAppTables.RemoveTables
        Set newAppTables = Nothing
    End If
End Sub


Private Sub InitializeTablesGeneric()

    On Error GoTo CleanFail

    Dim TableActions As Collection
    Dim ActionUpdate As TableActionGeneric

    Set TableActions = New Collection
    Set ActionUpdate = New TableActionGeneric

    TableActions.Add ActionUpdate, "Update"

    If newAppTables Is Nothing Then
        Set newAppTables = Tables.Create(TableActions, Me)
    End If

CleanExit:
    Exit Sub

CleanFail:
    Stop: Resume CleanExit

End Sub

Sheet: SheetY

'@Version(1)
'@Folder("App.TableTest")

Option Explicit

' Copywrite (C) 2019 Ricardo Diaz
' This file is distributed under the GPL-3.0 license
' Obtain a copy of the GPL-3.0 license <http://opensource.org/licenses/GPL-3.0>

Private newAppTables As ITables

Private Sub Worksheet_Activate()
    InitializeTablesCreateTask
End Sub

Private Sub Worksheet_Deactivate()
    If Not newAppTables Is Nothing Then
        newAppTables.RemoveTables
        Set newAppTables = Nothing
    End If
End Sub


Private Sub InitializeTablesCreateTask()

    On Error GoTo CleanFail

    Dim TableActions As Collection
    Dim ActionUpdate As TableActionUpdateCreateTask

    Set TableActions = New Collection
    Set ActionUpdate = New TableActionUpdateCreateTask

    TableActions.Add ActionUpdate, "Update"

    If newAppTables Is Nothing Then
        Set newAppTables = Tables.Create(TableActions, Me)
    End If

CleanExit:
    Exit Sub

CleanFail:
    Stop: Resume CleanExit

End Sub

Class: Tables

'@Folder("App.Tables")

Option Explicit
'@PredeclaredId

Private Type TTables
    Sheet As Worksheet
    Tables As Collection
    TableManagerActions As Collection

    Counter As Long
End Type

Private this As TTables

Implements ITables

Public Property Get Tables() As Collection
    Set Tables = this.Tables
End Property

Friend Property Set Tables(ByVal Value As Collection)
    Set this.Tables = Value
End Property

Public Property Get TableManagerActions() As Collection
    Set TableManagerActions = this.TableManagerActions
End Property

Friend Property Set TableManagerActions(ByVal Value As Collection)
    Set this.TableManagerActions = Value
End Property

Public Property Get Sheet() As Worksheet
    Set Sheet = this.Sheet
End Property

Friend Property Set Sheet(ByVal Value As Worksheet)
    Set this.Sheet = Value
End Property

Public Property Get Counter() As Long
    Counter = this.Counter
End Property

Friend Property Let Counter(ByVal Value As Long)
    this.Counter = Value
End Property

'
' Public Members
' --------------
'
Public Property Get Self() As Tables
    Set Self = Me
End Property

'
' Public Methods
' ---------------
'
Public Sub AddTables()

    Select Case True
    Case Counter = 0 Or Counter > Sheet.ListObjects.Count

        AddAllTablesInSheet

    Case Sheet.ListObjects.Count > Counter

        AddNewTable Sheet.ListObjects(Sheet.ListObjects.Count)

    End Select

    Counter = Sheet.ListObjects.Count

End Sub

Private Sub AddAllTablesInSheet()

    Dim evalTable As ListObject

    Set Tables = New Collection

    For Each evalTable In Sheet.ListObjects
        AddNewTable evalTable
    Next evalTable

End Sub

Private Sub AddNewTable(ByVal evalTable As ListObject)
    Dim NewTable As Table
    Set NewTable = Table.Create(TableManagerActions, evalTable)
    Tables.Add Item:=NewTable, Key:=evalTable.name
End Sub

Public Sub RemoveTables()
    Dim evalTable As ListObject
    For Each evalTable In Sheet.ListObjects
        Tables.Remove evalTable.name
    Next evalTable
End Sub

Public Function Create(ByVal Actions As Collection, ByVal SourceSheet As Worksheet) As ITables
    With New Tables
        Set .TableManagerActions = Actions
        Set .Sheet = SourceSheet
        Set Create = .Self
        .AddTables
    End With
End Function

Private Sub ITables_AddTables()
    AddTables
End Sub

Private Property Get ITables_Counter() As Long
    ITables_Counter = this.Counter
End Property

Private Sub ITables_RemoveTables()
    RemoveTables
End Sub

Class (Interface): ITables

'@Folder("App.Tables")
Option Explicit

Public Property Get Counter() As Long
End Property

Public Sub AddTables()
End Sub

Public Sub RemoveTables()
End Sub

Class: Table

'@Folder("App.Tables")
Option Explicit
'@PredeclaredId

Private Type TListObjectProtector
    RefTable As ListObject
    TableManagerActions As Collection

    TableValues As Variant

    RowsCount As Long
    ColumnsCount As Long
    PreviousRowsCount As Long
End Type

Private this As TListObjectProtector

'@MemberAttribute VB_VarHelpID, -1
Private WithEvents appExcel As Excel.Application

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

Public Property Set RefTable(ByVal objectRef As ListObject)
    Set this.RefTable = objectRef
End Property

Public Property Get TableManagerActions() As Collection
    Set TableManagerActions = this.TableManagerActions
End Property

Friend Property Set TableManagerActions(ByVal Value As Collection)
    Set this.TableManagerActions = Value
End Property

Public Property Get TableValues() As Variant
    TableValues = this.TableValues
End Property

Friend Property Let TableValues(ByVal Value As Variant)
    this.TableValues = Value
End Property

Public Property Get RowsCount() As Long
    RowsCount = this.RowsCount
End Property

Friend Property Let RowsCount(ByVal Value As Long)
    this.RowsCount = Value
End Property

Public Property Get ColumnsCount() As Long
    ColumnsCount = this.ColumnsCount
End Property

Friend Property Let ColumnsCount(ByVal Value As Long)
    this.ColumnsCount = Value
End Property

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

'
' Private Methods
' ---------------
'
Private Function GetAction() As String
    Select Case True
    Case RowsCount < RefTable.DataBodyRange.Rows.Count Or ColumnsCount < RefTable.ListColumns.Count
        GetAction = "Add"
    Case RowsCount > RefTable.DataBodyRange.Rows.Count Or ColumnsCount > RefTable.ListColumns.Count
        GetAction = "Delete"
    Case RowsCount = RefTable.DataBodyRange.Rows.Count And ColumnsCount = RefTable.ListColumns.Count
        GetAction = "Update"
    End Select
End Function

Private Sub LoadFromRange(ByVal Target As Range)

    Dim evalRange As Range

    Set evalRange = Intersect(Target, RefTable.DataBodyRange)

    If Not evalRange Is Nothing Then
        TableValues = RangeUtilities.RangeToArray(RefTable.DataBodyRange, False)
    End If

    ColumnsCount = RefTable.ListColumns.Count
    RowsCount = RefTable.DataBodyRange.Rows.Count

End Sub

Private Sub ProcessRange(ByVal Target As Range)

    Select Case GetAction
    Case "Add"
        MsgBox "Add"
    Case "Delete"
        MsgBox "delete"
    Case "Update"
        UpdateRange Target, "Update"
    End Select

End Sub

Private Sub UpdateRange(ByVal Target As Range, ByVal Action As String)

    Dim evalRange As Range
    Dim EvalCell As Range

    Dim previousValue As Variant
    Dim evalRow As Long
    Dim evalColumn As Long

    Set evalRange = Intersect(Target, RefTable.DataBodyRange)

    If evalRange Is Nothing Then Exit Sub

    For Each EvalCell In Target
        evalRow = ListObjectUtilities.GetCellRow(RefTable, EvalCell)
        evalColumn = ListObjectUtilities.GetCellColumn(RefTable, EvalCell)
        If IsArray(TableValues) Then
            previousValue = TableValues(evalRow, evalColumn)
        Else
            previousValue = TableValues
        End If
        If previousValue <> EvalCell.Value2 Then
            ProcessCell EvalCell, EvalCell.Value2, previousValue, Action
        End If
    Next EvalCell

End Sub

Private Sub ProcessCell(ByVal EvalCell As Range, ByVal CurrentValue As Variant, ByVal previousValue As Variant, ByVal Action As String)

    Dim strategy As ITableAction

    Set strategy = TableManagerActions.Item(Action)
    strategy.Run EvalCell, CurrentValue, previousValue

End Sub

Public Function Create(ByVal Actions As Collection, ByVal Table As ListObject) As Table
    With New Table
        Set .TableManagerActions = Actions
        Set .RefTable = Table
        .ColumnsCount = .RefTable.ListColumns.Count
        .RowsCount = .RefTable.DataBodyRange.Rows.Count
        Set Create = .Self
    End With
End Function

Private Sub Class_Initialize()
    Set appExcel = Excel.Application
    Set TableManagerActions = New Collection
End Sub

Private Sub Class_Terminate()
    Set Table = Nothing
    Set appExcel = Nothing
    Set TableManagerActions = Nothing
End Sub


Private Sub appExcel_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim evalRange As Range
    On Error Resume Next
    LogAction Sh.name, RefTable.name, "Change"
    On Error GoTo 0
    If RefTable Is Nothing Or Not ObjectUtilities.IsConnected(RefTable) Then Exit Sub
    If Not Sh Is RefTable.Parent Then Exit Sub
    Set evalRange = Intersect(Target, RefTable.DataBodyRange)
    If Not evalRange Is Nothing Then
        ProcessRange Target
    End If
End Sub

Private Sub appExcel_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Dim evalRange As Range
    On Error Resume Next
    LogAction Sh.name, RefTable.name, "SelectionChange"
    On Error GoTo 0
    If RefTable Is Nothing Or Not ObjectUtilities.IsConnected(RefTable) Then Exit Sub
    If Not Sh Is RefTable.Parent Then Exit Sub
    Set evalRange = Intersect(Target, RefTable.DataBodyRange)
    If Not evalRange Is Nothing Then
        LoadFromRange Target
    End If
End Sub

Private Sub LogAction(ByVal SheetName As String, ByVal TableName As String, ByVal ActionName As String)
    If SheetName = "Logger" Then Exit Sub
    Application.EnableEvents = False
    Logger.Cells(Logger.Rows.Count, "A").End(xlUp).Offset(1, 0).Value2 = SheetName
    Logger.Cells(Logger.Rows.Count, "B").End(xlUp).Offset(1, 0).Value2 = TableName
    Logger.Cells(Logger.Rows.Count, "C").End(xlUp).Offset(1, 0).Value2 = ActionName
    Application.EnableEvents = True
End Sub

Class (Interface): ITableAction

'@Version(1)
'@Folder("App.Tables")
Option Explicit

' Copywrite (C) 2019 Ricardo Diaz
' This file is distributed under the GPL-3.0 license
' Obtain a copy of the GPL-3.0 license <http://opensource.org/licenses/GPL-3.0>

Public Sub Run(ByVal EvalCell As Range, ByVal CurrentValue As Variant, ByVal previousValue As Variant)
End Sub

Class: TableActionGeneric

'@Version(1)
'@Folder("App.Tables.Actions")
Option Explicit

' Copywrite (C) 2019 Ricardo Diaz
' This file is distributed under the GPL-3.0 license
' Obtain a copy of the GPL-3.0 license <http://opensource.org/licenses/GPL-3.0>

Implements ITableAction

Private Sub ITableAction_Run(ByVal EvalCell As Range, ByVal CurrentValue As Variant, ByVal previousValue As Variant)
    MsgBox "Generic Action in table: " & EvalCell.ListObject.name & " from: " & previousValue & " To: " & CurrentValue & " in Cell: " & EvalCell.Address
End Sub

Class: TableActionUpdateCreateTask

'@Version(1)
'@Folder("App.Tables.Actions")
Option Explicit

' Copywrite (C) 2019 Ricardo Diaz
' This file is distributed under the GPL-3.0 license
' Obtain a copy of the GPL-3.0 license <http://opensource.org/licenses/GPL-3.0>

Implements ITableAction

Private Sub ITableAction_Run(ByVal EvalCell As Range, ByVal CurrentValue As Variant, ByVal previousValue As Variant)
    MsgBox "CreateTask Action in table: " & EvalCell.ListObject.name & " from: " & previousValue & " To: " & CurrentValue & " in Cell: " & EvalCell.Address
End Sub

Components - Utilities -

Class: ListObjectUtilities

'@Version(1)
'@Folder("Framework.Utilities")

Option Explicit
'@PredeclaredId


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, ByVal EvalCell As Range) As Long

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

    GetCellColumn = EvalCell.Column - evalTable.HeaderRowRange.Column + 1

End Function

' ----------------------------------------------------------------
' Procedure Name: AgregarReferenciar
' Purpose: Agregar una tabla estructurada para registrar información resultados
' Procedure Kind: Function
' Procedure Access: Public
' Parameter targetSheetResultados (Worksheet): targetSheet donde se almacena la tabla
' Parameter tableName (String): Nombre de la tabla
' Parameter ColumnList (Variant): Listado con nombres de columnas
' Return Type: ListObject
' Author: RicardoDiaz
' Date: 10/09/2019
' ----------------------------------------------------------------
'@Ignore AssignedByValParameter, ProcedureNotUsed
Public Function AddAndReference(ByVal TableName As String, Optional ByVal ColumnList As Variant, Optional ByVal TargetCell As Range, Optional ByVal ClearTableContents As Boolean = False, Optional ByVal TableStyleName As String) As ListObject


    Dim ExcelTable As ListObject

    If Exists(TableName) = False Then

        If TargetCell Is Nothing Then

            Set TargetCell = Application.InputBox(Prompt:= _
                            "La tabla " & TableName & " no existe, seleccione una ubicación para crearla", _
                            title:="Defina la ubicación", Type:=8)
        End If

        ' Agregar tabla estructurada
        Set ExcelTable = TargetCell.Parent.ListObjects.Add(SourceType:=xlSrcRange, source:=TargetCell)

        With ExcelTable
            .name = TableName
            ExcelTable.Resize .Range.Resize(, UBound(ColumnList) + 1)
            .HeaderRowRange.Value2 = ColumnList
        End With

    Else
        Set ExcelTable = Range(TableName).ListObject
    End If

    If TableStyleName <> vbNullString Then
        ExcelTable.TableStyle = TableStyleName
    End If

    If ClearTableContents = True Then
        If Not ExcelTable.DataBodyRange Is Nothing Then
            ExcelTable.DataBodyRange.Delete
        End If
    End If

    Set AddAndReference = ExcelTable

End Function

'@Ignore ProcedureNotUsed
Public Function AddAndReferenceRow(ByVal ExcelTable As ListObject, ByVal ColumnValues As Variant) As ListRow

    Dim newRow As ListRow

    Dim Counter As Long

    Set newRow = ExcelTable.ListRows.Add

    With newRow
        For Counter = 0 To UBound(ColumnValues)

            .Range(Counter + 1) = ColumnValues(Counter)

        Next Counter

    End With

    Set AddAndReferenceRow = newRow

End Function

'@Ignore ProcedureNotUsed
Public Function Exists(ByVal ListObjectName As String) As Boolean

    Dim evalListObject As ListObject

    On Error Resume Next

    Set evalListObject = Range(ListObjectName).ListObject

    On Error GoTo 0

    Exists = Not evalListObject Is Nothing

End Function

'@Ignore ProcedureNotUsed
Public Function GetRowByCriteria(ByVal ExcelTable As ListObject, ByVal Column1Header As String, _
            ByVal Column1Criteria As String, _
            Optional ByVal Column2Header As String, _
            Optional ByVal Column2Criteria As String, _
            Optional ByVal Column3Header As String, _
            Optional ByVal Column3Criteria As String) As ListRow

    Dim evalRow As ListRow
    Dim matchedRow As ListRow

    For Each evalRow In ExcelTable.DataBodyRange.ListObject.ListRows
        If Column2Header = vbNullString And Column3Header = vbNullString Then
            If (Intersect(evalRow.Range, ExcelTable.ListColumns(Column1Header).Range).Value = Column1Criteria) = True Then Set matchedRow = evalRow: Exit For
        ElseIf Column2Header <> vbNullString And Column3Header = vbNullString Then
            If (Intersect(evalRow.Range, ExcelTable.ListColumns(Column1Header).Range).Value = Column1Criteria) And _
                        (Intersect(evalRow.Range, ExcelTable.ListColumns(Column2Header).Range).Value = Column2Criteria) = True Then Set matchedRow = evalRow: Exit For
        ElseIf Column2Header <> vbNullString And Column3Header <> vbNullString Then
            If (Intersect(evalRow.Range, ExcelTable.ListColumns(Column1Header).Range).Value = Column1Criteria) And _
                        (Intersect(evalRow.Range, ExcelTable.ListColumns(Column2Header).Range).Value = Column2Criteria) And _
                        (Intersect(evalRow.Range, ExcelTable.ListColumns(Column3Header).Range).Value = Column3Criteria) = True Then Set matchedRow = evalRow: Exit For
        End If
    Next evalRow

    Set GetRowByCriteria = matchedRow

End Function

'@Ignore ProcedureNotUsed
Public Function HasExternalConnection(ByVal ListObjectName As String) As Boolean
    Dim evalSheet As Worksheet
    Dim evalListObject As ListObject

    For Each evalSheet In ThisWorkbook.Worksheets
        For Each evalListObject In evalSheet.ListObjects
            If evalListObject.name = ListObjectName Then
                If evalListObject.SourceType = xlSrcModel Or evalListObject.SourceType = xlSrcExternal Or evalListObject.SourceType = xlSrcQuery Then
                    HasExternalConnection = True
                    Exit For
                End If
            End If
        Next evalListObject
    Next evalSheet
End Function

'@Ignore ProcedureNotUsed
Public Sub DeleteRowsByCriteria(ByVal ExcelTable As ListObject, ByVal Column1Header As String, _
            ByVal Column1Criteria As String, _
            Optional ByVal Column2Header As String, _
            Optional ByVal Column2Criteria As String, _
            Optional ByVal Column3Header As String, _
            Optional ByVal Column3Criteria As String)

    Dim evalRow As ListRow

    Dim Counter As Long
    Dim totalRows As Long

    Dim deleteRow As Boolean

    totalRows = ExcelTable.ListRows.Count

    For Counter = totalRows To 1 Step -1
        Set evalRow = ExcelTable.ListRows(Counter)

        If Column2Header = vbNullString And Column3Header = vbNullString Then
            deleteRow = (Intersect(evalRow.Range, ExcelTable.ListColumns(Column1Header).Range).Value = Column1Criteria)
        ElseIf Column2Header <> vbNullString And Column3Header = vbNullString Then
            deleteRow = (Intersect(evalRow.Range, ExcelTable.ListColumns(Column1Header).Range).Value = Column1Criteria) And _
                        (Intersect(evalRow.Range, ExcelTable.ListColumns(Column2Header).Range).Value = Column2Criteria)
        ElseIf Column2Header <> vbNullString And Column3Header <> vbNullString Then
            deleteRow = (Intersect(evalRow.Range, ExcelTable.ListColumns(Column1Header).Range).Value = Column1Criteria) And _
                        (Intersect(evalRow.Range, ExcelTable.ListColumns(Column2Header).Range).Value = Column2Criteria) And _
                        (Intersect(evalRow.Range, ExcelTable.ListColumns(Column3Header).Range).Value = Column3Criteria)
        End If

        If deleteRow = True Then
            evalRow.Delete
        End If

    Next Counter

End Sub

Class: ObjectUtilities

'@Folder("Framework.Utilities")

Option Explicit
'@PredeclaredId

Private Const C_ERR_NO_ERROR = 0&
Private Const C_ERR_OBJECT_VARIABLE_NOT_SET = 91&
Private Const C_ERR_OBJECT_REQUIRED = 424&
Private Const C_ERR_DOES_NOT_SUPPORT_PROPERTY = 438&
Private Const C_ERR_APPLICATION_OR_OBJECT_ERROR = 1004&

Public Function IsConnected(ByVal Obj As Object) As Boolean
    ' Credits: http://www.cpearson.com/excel/ConnectedObject.htm
    ' Adapted by: Ricardo Diaz
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' IsConnected
    ' By Chip Pearson, chip@cpearson.com, www.cpearson.com
    ' http://www.cpearson.com/excel/ConnectedObject.htm
    '
    ' This procedure determines whether an object type variable is still connected
    ' to its target. An object variable can become disconnected from its target
    ' when the target object is destroyed. For example, the following code will
    ' raise an automation error because the target of the variable WS had been
    ' destoryed.
    '
    ' Dim WS As Worksheet
    ' Set WS = ActiveSheet
    ' ActiveSheet.Delete
    ' Debug.Print WS.Name
    '
    ' This code will fail on the "Debug.Print WS.Name" because the worksheet to
    ' which WS referenced was destoryed. It is important to note that WS will NOT
    ' be set to Nothing when the worksheet is deleted.
    '
    ' This procedure attempts to call the Name method of the Obj variable and
    ' then tests the result of Err.Number. We'll get the following error
    ' numbers:
    ' C_ERR_NO_ERROR
    ' No error occurred. We successfully retrieved the Name
    ' property. This indicates Obj is still connected to its
    ' target. Return TRUE.
    '
    ' C_ERR_OBJECT_VARIABLE_NOT_SET
    ' We'll get this error if the Obj variable has been
    ' disconnected from its target. Return FALSE.
    '
    ' C_ERR_DOES_NOT_SUPPORT_PROPERTY
    ' We'll get this error if the Obj variable does not have
    ' a name property. In this case, the Obj variable is still
    ' connected to its target. Return True.
    '
    ' C_ERR_APPLICATION_OR_OBJECT_ERROR
    ' This is a generic error message. If we get this error, we need to
    ' do further testing to get the connected state.
    '
    ' These are the only values that Err.Number should return. If we receive
    ' another error, err on the side of caution and return False.
    '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    '@Ignore VariableNotUsed
    Dim NameProp As String
    '@Ignore VariableNotUsed
    Dim ParentObj As Object

    On Error Resume Next
    Err.Clear

    NameProp = Obj.name

    On Error GoTo 0

    Select Case Err.Number
    Case C_ERR_NO_ERROR
        ' We'll get this result if we retrieve the Name property of Obj.
        ' Obj is connected.
        IsConnected = True

    Case C_ERR_DOES_NOT_SUPPORT_PROPERTY
        ' We'll get this result if Obj does not have a name property. This
        ' still indicates that Obj is connected.
        IsConnected = True

    Case C_ERR_OBJECT_VARIABLE_NOT_SET
        ' This indicates that Obj was Nothing, which we will treat
        ' as disconnected. If you want Nothing to indicate connected,
        ' test the variable Is Nothing before calling this procedure.
        IsConnected = False

    Case C_ERR_OBJECT_REQUIRED
        ' This indicates the object is disconnected. Return False
        IsConnected = False

    Case C_ERR_APPLICATION_OR_OBJECT_ERROR
        ' This error may occur when the object is either connected or disconnected.
        ' In this case, attempt to get the Parent property of the object.
        Err.Clear
        Set ParentObj = Obj.Parent
        Select Case Err.Number
        Case C_ERR_NO_ERROR
            ' we succuesfully got the parent object. Obj is connected.
            IsConnected = True
        Case C_ERR_DOES_NOT_SUPPORT_PROPERTY
            ' we'll get this error if Obj does not have a Parent property. This
            ' still indicates that Obj is connected.
            IsConnected = True
        Case C_ERR_OBJECT_VARIABLE_NOT_SET
            ' we'll get this error if Obj is disconnected
            IsConnected = False
        Case Else
            IsConnected = False
        End Select

    Case Else
        ' we should never get here, but return False if we do
        IsConnected = False
    End Select

End Function

Class: RangeUtilities

'@Version(1)
'@PredeclaredId
'@Folder("Framework.Utilities")

Option Explicit

'@Ignore ProcedureNotUsed
Public Function ToString(ByVal evalRange As Range, Optional ByVal separator As String) As String

    Dim EvalCell As Range
    Dim result As String

    For Each EvalCell In evalRange.Cells
        result = result & EvalCell.Value & separator
    Next EvalCell

    ToString = Left$(result, Len(result) - Len(separator))

End Function

'@Ignore ProcedureNotUsed
Public Function GetRangeName(ByVal Target As Range) As String

    On Error Resume Next

        GetRangeName = Target.name.name

    On Error GoTo 0

End Function

'@Ignore ProcedureNotUsed
Public Function RangeToArray(ByVal evalRange As Range, ByVal Transpose As Boolean) As Variant
    ' When Transpose = true the result will be a 1D array if there is only one row or one column
    If Transpose = True Then

        Select Case True
        Case evalRange.Rows.Count = 1 And evalRange.Columns.Count > 1
            RangeToArray = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(evalRange))
        Case evalRange.Rows.Count > 1 And evalRange.Columns.Count = 1
            RangeToArray = Application.WorksheetFunction.Transpose(evalRange)
        Case Else
            RangeToArray = evalRange.Value2
        End Select

    Else
        RangeToArray = evalRange.Value2
    End If

End Function
\$\endgroup\$
3
\$\begingroup\$

On the whole nice work! This is actually a problem I've looked at in the past, and as a result I'd like to review the approach you've taken and the API/ way users can interact with your code.


As I understand it you have 3 main classes

  1. Tables - responsible for instantiating a collection of Table objects (with some automagic methods to allow client code to attempt to keep this collection in sync so it reflects what's on the sheet)
  2. ITableAction implementations which are essentially callback functions with a strict interface that are triggered by updates to the tables
  3. The Table class - what actually wraps ListObjects and converts Application level events into triggers to run those TableActions

The rest is mostly just utility stuff and example code. Now I'd argue that classes 1. (mostly) and 2. are actually redundant and making your life a lot harder, let's take a step back and see how the approach could perhaps be simplified and made more VBA-idiomatic.


Starting with the constructor for the Table class:

Public Function Create(ByVal Actions As Collection, ByVal Table As ListObject) As Table
    With New Table
        Set .TableManagerActions = Actions
        Set .RefTable = Table
        .ColumnsCount = .RefTable.ListColumns.Count
        .RowsCount = .RefTable.DataBodyRange.Rows.Count
        Set Create = .Self
    End With
End Function

Private Sub Class_Initialize()
    Set appExcel = Excel.Application
    Set TableManagerActions = New Collection
End Sub

The Create method takes a Collection of actions, so why does the Class_Initialize method need to New one up?

And what about that appExcel - in this case you're lucky that Excel.Application will probably always refer to the same object, but better to supply that in the Create method too (dependency injection) - that will also make it easier to Unit Test as you can use a mock Excel.Application to raise events when you are testing.


While we're here, do we even need a reference to the Application? The only events you hook into are appExcel_SheetChange and appExcel_SheetSelectionChange - since a ListObject can never span multiple worksheets, why not declare

Private WithEvents listObjectParentSheet As Excel.Worksheet

and use the sheet level Change and SelectionChange events instead?

Better still, you can then use

Set listObjectParentSheet = Table.Parent

in the constructor to get the worksheet reference without passing it explicitly


I don't really like these names:

.ColumnsCount = .RefTable.ListColumns.Count
.RowsCount = .RefTable.DataBodyRange.Rows.Count

It looks like they might be the current value when really they are a cached value that's used in GetAction to see whether the dimensions of the table have changed. So name them as such: cachedColumnCount / previousColumnCount (drop the s too)


Now what about those actions. As I say, currently they are being used as callbacks; that is GetAction enumerates various changes to the table, ProcessRangeuses these enumerated action strings to call various routines which ultimately lead to invoking the action somewhere down the line:

Set strategy = TableManagerActions.Item(Action)
strategy.Run EvalCell, CurrentValue, previousValue

VBA already has a syntax for dealing with callbacks - Events. Instead of calling ITableAction_Run, your Table class could raise a custom Add or Delete or Update event. This way client code can listen for changes to the table, and hook any event handlers it fancies. You can then have different methods for handling events of different tables and don't need to construct a load of action objects.

In summary, the Table class then does the following things:

  1. Listen to the encapsulated ListObject's parent sheet for any changes
  2. Check whether these changes affect the encapsulated table, if so determine what kind of change occured (column added, row added, cell changed, table moved, row/column deleted etc.) by comparing to a cached version of the table.
  3. Generate any useful data you want the event listener to know about (If a row was added, which ListRow was it? If a cell was updated, then which cell and what was its previous value? If the table was moved, where from and to etc.)
  4. RaiseEvent ChangeKind(usefulData) to notify any listeners of the change and run their event handlers (instead of calling an ITableAction directly)

With those changes there will no longer be a need for TableActions. There will also be no TableManagerActions to save in the Tables collection, and therefore nothing in common between Table objects in the Tables collection except that they all live on the same worksheet.

At this point I'd do away with the Tables class entirely - the AddAllTablesInSheet method can become a module function that takes a sheet as a parameter and spits out a simple collection of Table objects, or maybe passes them to a class that does the event listening and handling.

| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ Great insights! what you're suggesting simplificates the whole deal. thank you @greedo. I have really limited knowledge in events, so I'll try to implement them and post a follow up question to check if I correctly understood them. \$\endgroup\$ – Ricardo Diaz Jan 8 at 15:10
  • \$\begingroup\$ This is my follow up question. Again thanks for the time you spent reviewing my code. Would appreciate if you can have a look at the new code. \$\endgroup\$ – Ricardo Diaz Jan 11 at 1:10

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.