Most of the VBA I write is to produce tabulated reports from spreadsheet data.
So, here is my attempt at creating a CLS_Data_Report class.
Properties:
a 2-dimensional Data Array
3 dictionaries to, respectively:
Map headers to column indexes
Map external (user-set) descriptions to data headers
Store number formatting for columns (by header)
And the PrintRange (for other visual formatting, e.g. row-colouring)
Key Methods:
Add Data to the Array (options for merging, overwriting, replacing)
Create a filtered report based on a single columns' values
Print the report to a worksheet (and set number formatting)
What I would especially like to know is, is this a good abstraction? (Is it too high, not high enough, is it trying to do too much, not enough?)
As always, any other feedback is greatly appreciated.
Properties and Class_Initialize
Option Explicit
Private pReportData As Variant '/ Data Array
Private pMapDescriptionsToHeaders As Scripting.Dictionary
Private pColumnIndexesOfHeaders As Scripting.Dictionary
Private pNumberFormatsOfHeaderColumns As Scripting.Dictionary
Private pPrintRange As Range
'/============================================================================================================================================================
Private Sub Class_Initialize()
pReportData = Array()
Set pMapDescriptionsToHeaders = New Scripting.Dictionary
Set pNumberFormatsOfHeaderColumns = New Scripting.Dictionary
Set pColumnIndexesOfHeaders = New Scripting.Dictionary
End Sub
Property Get/Set
'/============================================================================================================================================================
Public Property Get printRange() As Range
Set printRange = pPrintRange
End Property
Public Property Set printRange(ByRef printRange As Range)
Set pPrintRange = printRange
End Property
'/============================================================================================================================================================
Public Property Get reportData() As Variant
reportData = pReportData
End Property
Public Property Set reportData(ByRef inputArray As Variant)
pReportData = inputArray
End Property
'/============================================================================================================================================================
Public Property Get MapDescriptionsToHeaders() As Scripting.Dictionary
Set MapDescriptionsToHeaders = pMapDescriptionsToHeaders
End Property
Public Property Set MapDescriptionsToHeaders(ByRef descriptions As Scripting.Dictionary)
Set pMapDescriptionsToHeaders = MapDescriptionsToHeaders
End Property
'/============================================================================================================================================================
Public Property Get NumberFormatsOfHeaderColumns() As Scripting.Dictionary
Set NumberFormatsOfHeaderColumns = pNumberFormatsOfHeaderColumns
End Property
Public Property Set NumberFormatsOfHeaderColumns(ByRef numberFormats As Scripting.Dictionary)
Set pNumberFormatsOfHeaderColumns = numberFormats
End Property
'/============================================================================================================================================================
Public Property Get ColumnIndexesOfHeaders() As Scripting.Dictionary
Set ColumnIndexesOfHeaders = pColumnIndexesOfHeaders
End Property
Public Property Set ColumnIndexesOfHeaders(ByRef columnIndexes As Scripting.Dictionary)
Set pColumnIndexesOfHeaders = columnIndexes
End Property
Main Methods
'/============================================================================================================================================================
Public Sub AddDataToReport(ByRef inputArray As Variant, ByVal mergeArrays As Boolean, Optional ByVal unidHeader As Variant, Optional ByVal overrideValues As Boolean)
If mergeArrays Then
If IsMissing(unidHeader) Or IsMissing(overrideValues) Then PrintErrorMessage "Merge Arrays is specified but required arguments are not supplied"
End If
If ArrayIsAllocated(pReportData) Then
WriteDataToArray inputArray, mergeArrays, unidHeader, overrideValues
Else
ReplaceDataArray inputArray
End If
End Sub
Public Sub WriteDataToArray(ByRef inputArray As Variant, ByVal mergeArrays As Boolean, Optional ByVal unidHeader As Variant, Optional ByVal overrideValues As Boolean)
If mergeArrays Then
Dim unidRows As Scripting.Dictionary
Set unidRows = CreateDictOfUnidRowNumbers(inputArray, unidHeader)
End If
Dim targetArray As Variant
targetArray = pReportData
'/=========================================================================================================================
Dim inputLB1 As Long, inputUB1 As Long
Dim inputLB2 As Long, inputUB2 As Long
AssignArrayBounds inputArray, inputLB1, inputUB1, inputLB2, inputUB2
Dim inputHeaderRow As Variant
inputHeaderRow = RowFrom2dArray(inputArray, inputLB1)
'/=========================================================================================================================
Dim targetLB1 As Long, targetUB1 As Long
Dim targetLB2 As Long, targetUB2 As Long
AssignArrayBounds targetArray, targetLB1, targetUB1, targetLB2, targetUB2
Dim targetHeaderRow As Variant
targetHeaderRow = RowFrom2dArray(targetArray, targetLB1)
'/=========================================================================================================================
Dim i As Long, j As Long, k As Long
Dim ix As Long, iy As Long
Dim inputHeader As Variant, targetHeader As Variant
Dim inputCol As Long, targetCol As Long
Dim inputRow As Long, targetRow As Long
Dim inputValue As Variant
If mergeArrays Then
Dim unid As Variant, unidCol As Long
unidCol = IndexIn1dArray(inputHeaderRow, unidHeader)
End If
Dim headerMatchFound As Boolean, addValue As Boolean
'/ Add any missing headers
For iy = inputLB2 To inputUB2
inputCol = iy
inputHeader = inputArray(inputLB1, inputCol)
targetCol = targetLB2 - 1
headerMatchFound = False
For i = targetLB2 To targetUB2
targetHeader = targetArray(targetLB1, i)
If inputHeader = targetHeader Then
headerMatchFound = True
targetCol = i
Exit For
End If
Next i
If Not headerMatchFound Then
targetUB2 = targetUB2 + 1
ReDim Preserve targetArray(targetLB1 To targetUB1, targetLB2 To targetUB2)
targetArray(targetLB1, targetUB2) = inputHeader
SetColumnIndexOfHeader targetUB2, inputHeader
targetCol = targetUB2
End If
Next iy
Set ColumnIndexesOfHeaders = Me.ColumnIndexesFromHeadersInArray(targetArray)
'/ Add Values
targetHeaderRow = RowFrom2dArray(targetArray, targetLB1)
targetArray = Transpose2dArray(targetArray)
addValue = True
For ix = inputLB1 + 1 To inputUB1
inputRow = ix
inputValue = inputArray(inputRow, inputCol)
If mergeArrays Then
unid = inputArray(ix, unidCol)
If Not unidRows.Exists(unid) Then
targetUB1 = targetUB1 + 1
ReDim Preserve targetArray(targetLB2 To targetUB2, targetLB1 To targetUB1)
targetRow = targetUB1
Else
targetRow = unidRows.item(unid)
End If
addValue = Not (IsEmptyNothingOrNull(inputValue) And overrideValues)
Else
addValue = True
targetUB1 = targetUB1 + 1
ReDim Preserve targetArray(targetLB2 To targetUB2, targetLB1 To targetUB1)
targetRow = targetUB1
End If
If addValue Then
For iy = inputLB2 To inputUB2
inputCol = iy
inputHeader = inputArray(inputLB1, inputCol)
targetCol = ColumnIndexesOfHeaders.item(inputHeader)
inputValue = inputArray(inputRow, inputCol)
targetArray(targetCol, targetRow) = inputValue
Next iy
End If
Next ix
targetArray = Transpose2dArray(targetArray)
pReportData = targetArray
End Sub
'/============================================================================================================================================================
Public Sub PrintToWorksheet(ByRef startCell As Range)
Dim currentBook As Workbook, currentSheet As Worksheet
Set currentBook = ActiveWorkbook
Set currentSheet = ActiveSheet
Dim printBook As Workbook, printSheet As Worksheet
Set printSheet = startCell.Worksheet
Set printBook = printSheet.Parent
printBook.Activate
printSheet.Activate
Print2dArrayToSheet printBook, printSheet, pReportData, startCell
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds pReportData, LB1, UB1, LB2, UB2
Dim firstCol As Long, lastCol As Long
Dim firstRow As Long, lastRow As Long
firstCol = startCell.Column
firstRow = startCell.row
lastCol = firstCol + (UB2 - LB2)
lastRow = firstRow + (UB1 - LB1)
Set printRange = printSheet.Range(startCell, Cells(lastRow, lastCol))
Dim col As Long
Dim columnRange As Range
Dim header As Variant
Dim formatString As String
For col = firstCol To lastCol
With printSheet
header = .Cells(firstRow, firstCol)
If NumberFormatsOfHeaderColumns.Exists(header) Then
Set columnRange = .Range(Cells(firstRow, col), Cells(lastRow, col))
formatString = NumberFormatsOfHeaderColumns.item(header)
columnRange.NumberFormat = formatString
End If
End With
Next col
currentBook.Activate
currentSheet.Activate
End Sub
Auxilary Methods
'/============================================================================================================================================================
Public Sub SetDescriptionOfHeader(ByVal description As String, ByVal header As Variant)
pMapDescriptionsToHeaders.item(description) = header
End Sub
Public Function GetHeaderFromDescription(ByVal description As String) As Variant
If IsObject(pMapDescriptionsToHeaders.item(description)) Then
Set GetHeaderFromDescription = pMapDescriptionsToHeaders.item(description)
Else
GetHeaderFromDescription = pMapDescriptionsToHeaders.item(description)
End If
End Function
'/============================================================================================================================================================
Public Sub SetColumnIndexOfHeader(ByVal colIndex As Long, ByVal header As Variant)
pColumnIndexesOfHeaders.item(header) = colIndex
End Sub
Public Function GetColumnIndexOfHeader(ByVal header As Variant)
GetColumnFormattingOfHeader = pColumnIndexesOfHeaders.item(header)
End Function
'/============================================================================================================================================================
Public Sub SetColumnFormattingOfHeader(ByVal header As Variant, ByVal formatString As String)
pColumnIndexesOfHeaders.item(header) = formatString
End Sub
Public Function GetColumnFormattingOfHeader(ByVal header As Variant) As String
GetColumnFormattingOfHeader = pColumnIndexesOfHeaders.item(header)
End Function
'/============================================================================================================================================================
Public Function ColumnIndexesFromHeadersInArray(ByRef inputArray As Variant) As Scripting.Dictionary
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
Dim ixHeaderRow As Long, LB2 As Long, UB2 As Long
AssignArrayBounds inputArray, LB1:=ixHeaderRow, LB2:=LB2, UB2:=UB2
Dim header As Variant, columnIndex As Long
Dim iy As Long
For iy = LB2 To UB2
columnIndex = iy
header = inputArray(ixHeaderRow, iy)
dict.item(header) = columnIndex
Next iy
Set ColumnIndexesFromHeadersInArray = dict
End Function
'/============================================================================================================================================================
Public Function CreateDictOfUnidRowNumbers(ByRef inputArray As Variant, ByVal unidHeader As Variant) As Scripting.Dictionary
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
Dim LB1 As Long, UB1 As Long
AssignArrayBounds inputArray, LB1, UB1
Dim ixUnidColumn As Long
ixUnidColumn = pColumnIndexesOfHeaders.item(unidHeader)
Dim unid As Variant, row As Long
For row = LB1 To UB1
unid = inputArray(row, ixUnidColumn)
If dict.Exists(unid) Then
'/ TODO: Error Handling
Stop
Else
dict.item(unid) = row
End If
Next row
Set CreateDictOfUnidRowNumbers = dict
End Function
'/============================================================================================================================================================
Public Sub ReplaceDataArray(ByRef inputArray As Variant)
Erase pReportData
pReportData = inputArray
Set pColumnIndexesOfHeaders = ColumnIndexesFromHeadersInArray(pReportData)
End Sub
'/============================================================================================================================================================
Public Function GetFilteredReport(ByRef sourceReport As CLS_Data_Report, ByVal columnHeader As Variant, ByVal operator As ComparisonOperator, ByVal comparisonValue As Variant, ByVal keepOrRemoveOnTrue As KeepOrRemove) As CLS_Data_Report
Dim filteredReport As CLS_Data_Report
Set filteredReport = sourceReport.CloneProperties(sourceReport)
Dim filterColumn As Long
filterColumn = pColumnIndexesOfHeaders.item(columnHeader)
Dim dataArray As Variant
dataArray = filteredReport.reportData
dataArray = KeepOrRemoveArrayRowsWhereComparisonIsTrue(dataArray, filterColumn, operator, comparisonValue, hasHeaders:=True, keepOrRemoveOnTrue:=keepOrRemoveOnTrue)
filteredReport.ReplaceDataArray dataArray
Set GetFilteredReport = filteredReport
End Function
'/==============================================================================
Public Function CloneProperties(ByRef sourceReport As CLS_Data_Report) As CLS_Data_Report
Dim clonedReport As CLS_Data_Report
Set clonedReport = New CLS_Data_Report
Set clonedReport.printRange = sourceReport.printRange
Set clonedReport.reportData = sourceReport.reportData
Set clonedReport.MapDescriptionsToHeaders = sourceReport.MapDescriptionsToHeaders
Set clonedReport.ColumnIndexesOfHeaders = sourceReport.ColumnIndexesOfHeaders
Set clonedReport.NumberFormatsOfHeaderColumns = sourceReport.NumberFormatsOfHeaderColumns
Set CloneProperties = clonedReport
End Function
Used Methods from my "Standard Methods" Module
Option Explicit
Public Enum ComparisonOperator
NotEqualTo = 0
LessThan = 1
LessThanOrEqualTo = 2
EqualTo = 3
GreaterThanOrEqualTo = 4
GreaterThan = 5
End Enum
Public Enum KeepOrRemove
Remove = 0
Keep = 1
End Enum
Public Function GetWorkbook(ByVal wbFilename As String, Optional ByVal wbFilePath As String) As Workbook
Dim wbIsOpen As Boolean
wbIsOpen = IsWorkbookOpen(wbFilename)
If wbIsOpen Then
Set GetWorkbook = Workbooks(wbFilename)
Else
If Len(wbFilePath) = 0 Then PrintErrorMessage "Workbook (" & wbFilename & ") is not open, and no filepath was supplied", stopExecution:=True
Set GetWorkbook = Workbooks.Open(wbFilePath & wbFilename)
End If
End Function
Public Function IsWorkbookOpen(ByVal wbFilename As String) As Boolean
'/ Credit to @Mat's Mug [http://codereview.stackexchange.com/users/23788/mats-mug] for suggesting improvements here [http://codereview.stackexchange.com/questions/114156/get-workbook-methods]
On Error GoTo CleanFail:
IsWorkbookOpen = Not Workbooks(wbFilename) Is Nothing
CleanExit:
Exit Function
CleanFail:
Err.Clear
Resume CleanExit
End Function
Public Sub AssignArrayBounds(ByRef Arr As Variant, _
Optional ByRef LB1 As Variant, Optional ByRef UB1 As Variant, _
Optional ByRef LB2 As Variant, Optional ByRef UB2 As Variant, _
Optional ByRef LB3 As Variant, Optional ByRef UB3 As Variant, _
Optional ByRef LB4 As Variant, Optional ByRef UB4 As Variant, _
Optional ByRef LB5 As Variant, Optional ByRef UB5 As Variant)
If Not IsMissing(LB1) Then LB1 = LBound(Arr, 1)
If Not IsMissing(UB1) Then UB1 = UBound(Arr, 1)
If Not IsMissing(LB2) Then LB2 = LBound(Arr, 2)
If Not IsMissing(UB2) Then UB2 = UBound(Arr, 2)
If Not IsMissing(LB3) Then LB3 = LBound(Arr, 3)
If Not IsMissing(UB3) Then UB3 = UBound(Arr, 3)
If Not IsMissing(LB4) Then LB4 = LBound(Arr, 4)
If Not IsMissing(UB4) Then UB4 = UBound(Arr, 4)
If Not IsMissing(LB5) Then LB5 = LBound(Arr, 5)
If Not IsMissing(UB5) Then UB5 = UBound(Arr, 5)
End Sub
Public Function Transpose2dArray(ByRef sourceArray As Variant) As Variant
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
Dim i As Long, j As Long
AssignArrayBounds sourceArray, LB1, UB1, LB2, UB2
Dim transposedArray() As Variant
ReDim transposedArray(LB2 To UB2, LB1 To UB1)
For i = LB1 To UB1
For j = LB2 To UB2
transposedArray(j, i) = sourceArray(i, j)
Next j
Next i
Transpose2dArray = transposedArray
End Function
Public Function RowFrom2dArray(ByRef sourceArray As Variant, ByVal rowIndex As Long) As Variant
Dim LB2 As Long, UB2 As Long
Dim i As Long
Dim rowArray As Variant
rowArray = Array()
AssignArrayBounds sourceArray, LB2:=LB2, UB2:=UB2
ReDim rowArray(LB2 To UB2)
For i = LB2 To UB2
rowArray(i) = sourceArray(rowIndex, i)
Next i
RowFrom2dArray = rowArray
End Function
Public Function IndexIn1dArray(ByRef sourceArray As Variant, ByVal searchItem As Variant, Optional ByVal nthMatch As Long = 1) As Variant
Dim ix As Long, i As Long
Dim matchesFound As Boolean, matchCounter As Long
Dim LB1 As Long, UB1 As Long
AssignArrayBounds sourceArray, LB1, UB1
matchCounter = 0
i = LB1
Do Until matchCounter = nthMatch Or i > UB1
If sourceArray(i) = searchItem Then
matchCounter = matchCounter + 1
ix = i
End If
i = i + 1
Loop
matchesFound = (matchCounter = nthMatch)
If matchesFound Then
IndexIn1dArray = ix
Else
IndexIn1dArray = CVErr(xlErrValue)
End If
End Function
Public Sub CloseWorkbook(ByRef wbTarget As Workbook)
Application.DisplayAlerts = False
wbTarget.Close
Application.DisplayAlerts = True
End Sub
Public Function Remove2DArrayRows(ByRef sourceArray As Variant, ByRef rowListArray As Variant) As Variant
Dim targetArray As Variant
targetArray = Array()
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds sourceArray, LB1, UB1, LB2, UB2
ReDim targetArray(LB2 To UB2, LB1 To LB1)
rowListArray = SortArrayList(rowListArray, sortAscending:=True)
Dim row As Long, col As Long
Dim copyCounter As Long, ixListArray As Long
copyCounter = 0
ixListArray = LBound(rowListArray)
For row = LB1 To UB1
If row = rowListArray(ixListArray) Then
ixListArray = ixListArray + 1
If ixListArray > UBound(rowListArray) Then ixListArray = UBound(rowListArray)
Else
ReDim Preserve targetArray(LB2 To UB2, LB1 To LB1 + copyCounter)
For col = LB2 To UB2
targetArray(col, LB1 + copyCounter) = sourceArray(row, col)
Next col
copyCounter = copyCounter + 1
End If
Next row
targetArray = Transpose2dArray(targetArray)
Remove2DArrayRows = targetArray
End Function
Public Function KeepOrRemoveArrayRowsWhereComparisonIsTrue(ByRef sourceArray As Variant, ByVal colIndex As Long, ByVal operator As ComparisonOperator, ByVal comparisonValue As Variant, ByVal hasHeaders As Boolean, ByVal keepOrRemoveOnTrue As KeepOrRemove) As Variant
Dim LB1 As Long, UB1 As Long
AssignArrayBounds sourceArray, LB1, UB1
Dim rowsToBeRemoved As Variant, removeCounter As Long
rowsToBeRemoved = Array()
ReDim rowsToBeRemoved(1 To 1)
Dim ix As Long, startRow As Long
If hasHeaders Then startRow = LB1 + 1 Else startRow = LB1
Dim sourceValue As Variant
Select Case keepOrRemoveOnTrue
Case Is = KeepOrRemove.Keep
removeCounter = 0
For ix = startRow To UB1
sourceValue = sourceArray(ix, colIndex)
If Not ComparisonIsTrue(sourceValue, operator, comparisonValue) Then
removeCounter = removeCounter + 1
ReDim Preserve rowsToBeRemoved(1 To removeCounter)
rowsToBeRemoved(removeCounter) = ix
End If
Next ix
Case Is = KeepOrRemove.Remove
removeCounter = 0
For ix = startRow To UB1
sourceValue = sourceArray(ix, colIndex)
If ComparisonIsTrue(sourceValue, operator, comparisonValue) Then
removeCounter = removeCounter + 1
ReDim Preserve rowsToBeRemoved(1 To removeCounter)
rowsToBeRemoved(removeCounter) = ix
End If
Next ix
End Select
sourceArray = Remove2DArrayRows(sourceArray, rowsToBeRemoved)
KeepOrRemoveArrayRowsWhereComparisonIsTrue = sourceArray
End Function
Public Function ComparisonIsTrue(ByVal sourceValue As Variant, ByVal operator As ComparisonOperator, ByVal comparisonValue As Variant) As Boolean
Dim isTrue As Boolean
Select Case operator
Case ComparisonOperator.NotEqualTo
isTrue = (sourceValue <> comparisonValue)
Case ComparisonOperator.LessThan
isTrue = (sourceValue < comparisonValue)
Case ComparisonOperator.LessThanOrEqualTo
isTrue = (sourceValue <= comparisonValue)
Case ComparisonOperator.EqualTo
isTrue = (sourceValue = comparisonValue)
Case ComparisonOperator.GreaterThanOrEqualTo
isTrue = (sourceValue >= comparisonValue)
Case ComparisonOperator.GreaterThan
isTrue = (sourceValue > comparisonValue)
Case Else
'/ Error Handling
Stop
End Select
ComparisonIsTrue = isTrue
End Function
Public Function ArrayIsAllocated(inputArray As Variant) As Boolean
On Error Resume Next
ArrayIsAllocated = IsArray(inputArray) And Not IsError(LBound(inputArray, 1)) And LBound(inputArray, 1) <= UBound(inputArray, 1)
On Error GoTo 0
End Function
