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 insheet x
theAction
that is executed should begeneric action
and if table is located insheet y
theAction
that is executed should becreate a task
Actions
depend on what is happening with thetable
, i.e., there should be anAction
for the event ofAdding
rows and a different one forDeleting
rowsActions
should know what triggered them, e.g.,Sheet
,Table
andCell
- If user adds a new
Table
to aSheet
it should also respond to theActions
performed in it'scells
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 arange
inside an ExcelTable
- 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
- Program displays what was the previous value and the new value in the modified
Sample use case #2:
- User adds a new Excel
Table
(ListObject) to SheetY - User modifies a
cell
in the new ExcelTable
- An
action
is executed:- Program displays what was the previous value and the new value in the modified
cell
- Program displays what was the previous value and the new value in the modified
Sample use case #3:
- User deletes an Excel
Table
(ListObject) from SheetY - User modifies a
cell
in another ExcelTable
- An
action
is executed:- Program displays what was the previous value and the new value in the modified
cell
- Program displays what was the previous value and the new value in the modified
Would appreciate your review to find out:
- If code design expectations are correctly implemented
- How to implement a factory pattern (if it's useful in this case)
- How to implement unit tests
- If this approach is efficient (e.g. the way I'm handling how to store the table range previous values)
- Any other insight you may consider
Reference
- Rubberduck-VBA blog
- Answers related to these subjects from Mathieu Guindon
Current file
You can download the demo file from here
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)
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, [email protected], 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