I'm (re)building a data table to track our clients that receive regular income payments. Specifically, I need to pull this data into other workbooks for other reports, and since I was here anyway I decided to upgrade it and anticipate its' future growth.
A sample of the data table (minus sensitive data):
My code finds the Table Range, Determines the location of the sort-columns, Sorts the table using a 2-Level custom sort (then A-Z by name) and then does some visual formatting.
There is a sheet for every year and a button on each sheet, all linking to the same Macro, which operates on the Active Sheet.
These days, my main focus is on Maintainability (by me or someone else). In essence, if you got hired and were handed this as a thing to maintain, what would you be thinking as you read through it?
(There are a few standard methods not included. You may safely assume they do what they say they do)
Module "A1_Public_Variables" Option Explicit
Public Const TOP_LEFT_CELL_STRING As String = "Client Name"
Public Const CLIENT_NAME_HEADER As String = "Client Name"
Public Const INCOME_AMOUNT_HEADER As String = "Income"
Public Const PAYMENT_FREQUENCY_HEADER As String = "Frequency"
Public Const PAYMENT_DAY_HEADER As String = "Date Paid"
Public Const BASE_MONTH_HEADER As String = "Base Month"
Public Const ASCENTRIC_WRAPPER_HEADER As String = "Wrapper"
Public Const ASCENTRIC_ACCOUNT_NUMBER_HEADER As String = "Ascentric Acc #"
Public Const ACCOUNT_TO_PAY_FROM_HEADER As String = "Account to pay from?"
Module "B1_Sort_Button_Click" Option Explicit
Sub BtnSort_Click()
'/====================================================================================================
'/ Description:
'/ For the active sheet, finds the data Table and sortKey columns using headers.
'/ Sorts clients based on payment frequency, then payment day, then Client Name.
'/ Colours rows depending on their payment frequency.
'/====================================================================================================
StoreApplicationSettings
DisableApplicationSettings
'/ set Worksheet
Dim ws_this As Worksheet
Set ws_this = ActiveSheet
'/ Get table Range
Dim tableRange As Range
Set tableRange = GetTableRange(ws_this)
'/ Validate Column Headers
ValidateTableHeaders ws_this, tableRange
'/ Get sort columns
Dim paymentFrequencyColNum As Long
Dim paymentDayColNum As Long
Dim clientNameColNum As Long
FindColumnIndexes ws_this, tableRange, paymentFrequencyColNum, paymentDayColNum, clientNameColNum
'/ Sort Table
SortTableRange ws_this, tableRange, paymentFrequencyColNum, paymentDayColNum, clientNameColNum
'/ Visual Formatting
FormatTableRange ws_this, tableRange, paymentFrequencyColNum
RestoreApplicationSettings
End Sub
Module "B2_Get_Table" Option Explicit
Public Function GetTableRange(ByRef ws_this As Worksheet) As Range
'/ Finds the top left cell in the table by its' text. Determines the bounds of the table and returns it as a range object.
'/ Find top left cell of table
Dim searchRange As Range
Set searchRange = ws_this.Range(Cells(1, 1), Cells(10, 10))
Dim topLeftCell As Range
Set topLeftCell = CellContainingStringInRange(searchRange, TOP_LEFT_CELL_STRING)
'/ Find table range
Dim finalRow As Long, finalCol As Long
Dim row As Long, col As Long
row = topLeftCell.row
col = topLeftCell.Column
finalRow = Cells(Rows.Count, col).End(xlUp).row
finalCol = Cells(row, Columns.Count).End(xlToLeft).Column
Set GetTableRange = Range(topLeftCell, Cells(finalRow, finalCol))
End Function
Module "B3_Validate_Table_headers"
Option Explicit
Public Sub ValidateTableHeaders(ByRef ws_this As Worksheet, ByRef tableRange As Range)
'/ Checks for the existence of all expected headers.
ws_this.Activate
'/ Get Expected Headers
Dim passedValidation As Boolean
Dim strErrorMessage As String
Dim expectedHeaders(1 To 21) As String '/ 9 headers + 12 months
ThisWorkbook.GetDataTableHeaders expectedHeaders(1), expectedHeaders(2), expectedHeaders(3), expectedHeaders(4), expectedHeaders(5) _
, expectedHeaders(6), expectedHeaders(7), expectedHeaders(8), expectedHeaders(9)
Dim i As Long
For i = (UBound(expectedHeaders) - 11) To UBound(expectedHeaders)
expectedHeaders(i) = MonthName(i - UBound(expectedHeaders) + 12)
Next i
'/ Get Header Row
Dim arrHeaderRow As Variant
arrHeaderRow = Array()
Dim row As Long, col As Long
Dim firstCol As Long, finalCol As Long
row = tableRange.row
firstCol = tableRange.Column
finalCol = firstCol + (tableRange.Columns.Count - 1)
ReDim arrHeaderRow(firstCol To finalCol)
For col = firstCol To finalCol
arrHeaderRow(col) = Cells(row, col).Text
Next col
'/ Search header row for all expected Headers
Dim LB1 As Long, UB1 As Long
AssignArrayBounds expectedHeaders, LB1, UB1
Dim ix As Variant
Dim searchString As String
passedValidation = True
For i = LB1 To UB1
searchString = expectedHeaders(i)
ix = IndexInArray1d(arrHeaderRow, searchString)
If IsError(ix) Then
passedValidation = False
strErrorMessage = strErrorMessage & "Could not find header """ & searchString & """ (non-case sensitive)"
End If
Next i
'/ If applicable, show error message and stop execution
If Not passedValidation Then PrintErrorMessage strErrorMessage, endExecution:=True
End Sub
Module "B4_Get_Column_Indexes"
Option Explicit
Public Sub FindColumnIndexes(ByRef ws_this As Worksheet, ByRef tableRange As Range, ByRef paymentFrequencyColNum As Long, ByRef paymentDayColNum As Long, ByRef clientNameColNum As Long)
'/ Pulls out the header row as an array. Search for specific headers and returns their column numbers.
ws_this.Activate
'/ Get Header Row as range
Dim rngHeaderRow As Range
Dim lngHeaderRow As Long
Dim firstCol As Long, finalCol As Long
firstCol = tableRange.Column
finalCol = firstCol + (tableRange.Columns.Count - 1)
lngHeaderRow = tableRange.row
Set rngHeaderRow = Range(Cells(lngHeaderRow, firstCol), Cells(lngHeaderRow, finalCol))
'/ Read Header Row to Array
Dim arrHeaderRow As Variant
arrHeaderRow = Array()
Dim col As Long, i As Long
ReDim arrHeaderRow(1 To tableRange.Columns.Count)
For col = firstCol To finalCol
i = (col - firstCol) + 1
arrHeaderRow(i) = Cells(lngHeaderRow, col).Text
Next col
'/ Find column numbers
paymentFrequencyColNum = IndexInArray1d(arrHeaderRow, PAYMENT_FREQUENCY_HEADER) + (firstCol - 1)
paymentDayColNum = IndexInArray1d(arrHeaderRow, PAYMENT_DAY_HEADER) + (firstCol - 1)
clientNameColNum = IndexInArray1d(arrHeaderRow, CLIENT_NAME_HEADER) + (firstCol - 1)
End Sub
Module "B5_Sort_Table"
Option Explicit
Public Sub SortTableRange(ByRef ws_this As Worksheet, ByRef tableRange As Range, ByVal paymentFrequencyColNum As Long, ByVal paymentDayColNum As Long, ByVal clientNameColNum As Long)
'/ Sorts range based on payment frequency, then payment day, then Client Name, using custom sort lists for the first 2.
ws_this.Activate
'/ Get Custom sort list for payment frequency
Dim paymentFrequencySortList As Variant
paymentFrequencySortList = GetpaymentFrequencySortList()
Dim strPaymentFrequencySortList As String
strPaymentFrequencySortList = Join(paymentFrequencySortList, ",")
'/ Get Custom sort list for payment day
Dim paymentDaySortList As Variant
paymentDaySortList = GetPaymentDaySortList()
Dim strPaymentDaySortList As String
strPaymentDaySortList = Join(paymentDaySortList, ",")
'/ Get first/last rows
Dim firstRow As Long, finalRow As Long
firstRow = tableRange.row
finalRow = firstRow + (tableRange.Rows.Count - 1)
'/ get column ranges
Dim rngPaymentFrequencyCol As Range, rngPaymentDayCol As Range, rngClientNameCol As Range
Set rngPaymentFrequencyCol = Range(Cells(firstRow, paymentFrequencyColNum), Cells(finalRow, paymentFrequencyColNum))
Set rngPaymentDayCol = Range(Cells(firstRow, paymentDayColNum), Cells(finalRow, paymentDayColNum))
Set rngClientNameCol = Range(Cells(firstRow, clientNameColNum), Cells(finalRow, clientNameColNum))
'/ Sort Range
With ws_this.Sort
.SortFields.Clear
.SortFields.Add key:=rngPaymentFrequencyCol, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=CVar(strPaymentFrequencySortList) '/ CVar is necessary to get VBA to accept the string. No idea why.
.SortFields.Add key:=rngPaymentDayCol, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=CVar(strPaymentDaySortList)
.SortFields.Add key:=rngClientNameCol, SortOn:=xlSortOnValues, Order:=xlAscending
.SetRange tableRange
.Header = xlYes
.MatchCase = False
.SortMethod = xlPinYin
.Apply
End With
End Sub
Public Function GetpaymentFrequencySortList() As Variant
Dim arr As Variant
arr = Array()
ReDim arr(1 To 3)
arr(1) = "Monthly" '/ "Low" item
arr(2) = "Quarterly"
arr(3) = "Annually" '/ "High" item
GetpaymentFrequencySortList = arr
End Function
Public Function GetPaymentDaySortList() As Variant
Dim arr As Variant
arr = Array()
ReDim arr(1 To 31)
arr(1) = "1st" '/ "Low" Item
arr(2) = "2nd"
arr(3) = "3rd"
arr(4) = "4th"
arr(5) = "5th"
arr(6) = "6th"
arr(7) = "7th"
arr(8) = "8th"
arr(9) = "9th"
arr(10) = "10th"
arr(11) = "11th"
arr(12) = "12th"
arr(13) = "13th"
arr(14) = "14th"
arr(15) = "15th"
arr(16) = "16th"
arr(17) = "17th"
arr(18) = "18th"
arr(19) = "19th"
arr(20) = "20th"
arr(21) = "21st"
arr(22) = "22nd"
arr(23) = "23rd"
arr(24) = "24th"
arr(25) = "25th"
arr(26) = "26th"
arr(27) = "27th"
arr(28) = "28th"
arr(29) = "29th"
arr(30) = "30th"
arr(31) = "31st" '/ "High" Item
GetPaymentDaySortList = arr
End Function
Module "B6_Format_Table" Option Explicit
Public Sub FormatTableRange(ByRef ws_this As Worksheet, ByRef tableRange As Range, ByVal paymentFrequencyColNum As Long)
'/ Colour rows based on Payment frequency, add cell borders, autofit columns and then set the "Cash Made Available?" columns to fixed-width.
ws_this.Activate
'/ Set fixed width for "Cash Made Available?" columns
Dim colWidthCashAvailable As Long
colWidthCashAvailable = 10
'/ Set Range bounds of table
Dim firstRow As Long, firstCol As Long
Dim finalRow As Long, finalCol As Long
Dim topLeftCell As Range
Set topLeftCell = Cells(tableRange.row, tableRange.Column)
AssignRangeBoundsOfData topLeftCell, firstRow, finalRow, firstCol, finalCol, False
Dim firstCashAvailableCol As Long
firstCashAvailableCol = finalCol - (12 - 1) '/ 12 months
'/ Colour rows based on payment frequency
ws_this.Cells.Interior.Color = xlNone
Dim row As Long, col As Long
Dim paymentFrequency As String
Dim strColour As String, dblColourShade As Double
Dim rngRow As Range
For row = firstRow + 1 To finalRow '/ +1 for headers
'/ Set strColour inside conditions in case we want to use different colours for each in the future
paymentFrequency = Cells(row, paymentFrequencyColNum).Text
Set rngRow = Range(Cells(row, firstCol), Cells(row, finalCol))
Select Case paymentFrequency
Case Is = "Monthly"
strColour = "Lumin Tourquoise"
dblColourShade = DblBaseShade - (DblShadeIncrement * -6)
ColourFill rngRow, strColour, dblColourShade
Case Is = "Quarterly"
strColour = "Lumin Tourquoise"
dblColourShade = DblBaseShade - (DblShadeIncrement * -4)
ColourFill rngRow, strColour, dblColourShade
Case Is = "Annually"
strColour = "Lumin Tourquoise"
dblColourShade = DblBaseShade - (DblShadeIncrement * -2)
ColourFill rngRow, strColour, dblColourShade
Case Else
ErrorMessage "Couldn't identify frequency """ & paymentFrequency & """ on row " & row & ". Please check that it is entered correctly."
End Select
Next row
'/ Set Borders
Dim rngCell As Range
ws_this.Cells.Borders.LineStyle = xlNone
For row = firstRow + 1 To finalRow '/ +1 for headers
Set rngRow = Range(Cells(row, firstCol), Cells(row, finalCol))
For Each rngCell In rngRow
rngCell.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
Next rngCell
Next row
'/ Set Header Borders
Dim rngHeaderRow As Range
Set rngHeaderRow = Range(Cells(firstRow, firstCol), Cells(firstRow, finalCol))
For Each rngCell In rngHeaderRow
rngCell.BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
Next rngCell
Set rngCell = Range(Cells(firstRow - 1, firstCashAvailableCol), Cells(firstRow - 1, finalCol)) '/ The extra "Cash made available" Header Cell
rngCell.BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
'/ Set column widths
ws_this.Columns.AutoFit
For col = firstCashAvailableCol To finalCol
Columns(col).ColumnWidth = colWidthCashAvailable
Next col
End Sub
.Activate
s? \$\endgroup\$Cvar
\$\endgroup\$