'only the column name of the last cell in the report
Private Const msLAST_CELL As String = "BZ"
' you can change this to vbTab or " " if you do not want a new line after each name
Private Const msNAME_SEPARATOR As String = vbCrLf
' do not change this unless you are adapting to a foreign version of Excel where formula parameters are separated by something other than a comma
Private Const msFORMULA_SEPARATOR As String = ","
' this is the column address where the Name is located on the data sheet; adjust if necessary
Private Const msNAMES_COLUMN As String = "C:C"
' name of the data sheet; update for each new year
Private Const msDATA_SHEET As String = "FY19 Confirmed Movement"
' name of the summary sheet, where the COUNTIFS functions are located
Private Const msSUMMARY_SHEET As String = "Summary"
' the comment will say this if COUNTIFS returns 0
Private Const msZERO_RESULTS_TEXT As String = "The criteria returns zero results."
' left side of the notice if comment length is exceeded
Private Const msNOTICE_TEXT_LEFT As String = vbCrLf & "...and another "
'right side of the notice if comment length is exceeded; the number of skipped names is inserted between
Private Const msNOTICE_TEXT_RIGHT As String = " item(s)."
'maximum length of a comment, in characters; do not exceed 32,000; reduce if you want comments to be shorter
Private Const miMAX_COMMENT_LENGTH As Long = 32000
' this string will store the procedure currently used, and will be reported if an error occurs; this helps for troubleshooting / debugging
Private msSource As String
Public Sub InsertComment()
Dim rngSel As Excel.Range
Dim rng As Excel.Range
Dim vCriteria As Variant
Dim i As Integer
Dim sFormula As String
Dim sResult As String
Dim calcs As Excel.XlCalculation
msSource = "InsertComment entry point procedure"
' On Error GoTo cleanup
' turn off automatic calculations for faster execution
With Application
calcs = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' make sure the selection is a range
If StrComp(LCase$(TypeName(Selection)), "range") <> 0 Then
Call MsgBox("Please select some cells first!", vbOKOnly + vbInformation)
GoTo cleanup
End If
Set rngSel = Application.Selection
' loop through the selected cells
For Each rng In rngSel.Cells
' only process cells that have a formula
If rng.HasFormula Then
sFormula = rng.Formula
' only process formula cells that have a COUNTIFS function
If InStr(1, UCase$(sFormula), "COUNTIFS") > 0 Then
' recalculate the current cell
rng.Calculate
' make sure the cell is non-zero value
' if the COUNTIFS returns zero, we skip to the next cell
If Abs(rng.Value) > 0 Then
vCriteria = vParseFormula(sFormula)
msSource = "InsertComment entry point procedure"
sResult = sGetNames(vCriteria)
msSource = "InsertComment entry point procedure"
Else
sResult = msZERO_RESULTS_TEXT
End If
' add the comment
' delete any previous comment
On Error Resume Next
rng.Comment.Delete
On Error GoTo cleanup
rng.AddComment sResult
Else
Debug.Print "'" & rng.Parent.Name & "'!" & rng.Address & " does not contain a COUNTIFS."
End If
End If
Next rng
cleanup:
' restore settings
With Application
.Calculation = calcs
.ScreenUpdating = True
End With
' if there is an error message, report this information
If Err.Number <> 0 Then
Call MsgBox("An error occurred :(" & _
vbCrLf & vbCrLf & Err.Number & ": " & Err.Description & _
vbCrLf & vbCrLf & "Source: " & msSource, vbExclamation + vbOKOnly, "Oops...")
End If
End Sub
' This function returns the digit length of an integer
' 1-9 = 1
' 10-99 = 2
' 100-999 = 3
' etc
Private Function iGetNumLen(iNum As Long) As Integer
msSource = "iGetNumLen private function"
iGetNumLen = Application.WorksheetFunction.RoundUp(Log(iNum + 1) / Log(10), 0)
End Function
' This function returns a one-dimensional array containing the parameters of a COUNTIFS function
' Only the first COUNTIFS function will be considered
Private Function vParseFormula(sFormula As String) As Variant
Dim iLeftParen As Integer
Dim iRightParen As Integer
Dim sSubstring As String
Dim v As Variant
msSource = "vParseFormula private function"
' find the opening and closing parentheses
iLeftParen = InStr(1, sFormula, "COUNTIFS")
iLeftParen = InStr(iLeftParen, sFormula, "(")
iRightParen = InStr(1, sFormula, ")")
' extract the parameters in-between the parentheses
sSubstring = Mid$(Trim(sFormula), iLeftParen + 1, iRightParen - iLeftParen - 1)
' split the string by delimeter, isolating each of the parameters
vParseFormula = Split(sSubstring, msFORMULA_SEPARATOR)
End Function
' This function performs an Advanced Filter operation, and returns a delimited list of values
' that match the criteria of a COUNTIFS function.
' The input is a one-dimensional variant array of the parameters of a COUNTIFS function
Private Function sGetNames(vCriteria As Variant) As String
Dim rngResult As Excel.Range
Dim rngData As Excel.Range
Dim rngCriteria As Excel.Range
Dim rngOutput As Excel.Range
Dim sValue As String
Dim rngValue1 As Excel.Range
Dim rngValue2 As Excel.Range
Dim rng As Excel.Range
Dim wshSummary As Excel.Worksheet
Dim wshData As Excel.Worksheet
Dim iMaxLen As Long
Dim iLenNotice As Long
Dim iNumCriteria As Long
Dim iShift As Long
Dim i As Long
Dim j As Long
Dim s As String
msSource = "sGetNames private function"
' identify the relevant sheets
Set wshSummary = ActiveWorkbook.Worksheets(msSUMMARY_SHEET)
Set wshData = ActiveWorkbook.Worksheets(msDATA_SHEET)
' shift the array so that it is 1-to-N dimensionality
' this avoids the computational issues related to zero-based arrays, or a non-standard dimensionality
iShift = 1 - LBound(vCriteria)
ReDim Preserve vCriteria(LBound(vCriteria) + iShift To UBound(vCriteria) + iShift)
' this is OK because the array is now a 1-based index
iNumCriteria = UBound(vCriteria) / 2
' create the two-dimensional array to hold the Advanced Filter criteria
ReDim vHeaders(1 To iNumCriteria, 1 To 2)
' set up the criteria array
' each odd-numbered element is COUNTIFS criteria range
' each even-numbered element is COUNTIFS criteria value
For i = 1 To UBound(vCriteria) Step 2
' i is the counter for criteria range
' j is the counter for criteria value
j = i + 1
' look at the odd-numbered element
' if the criteria contains a sheet name (determined by presence of !), use the entire criteria
' if the criteria does not contain a cell range (determined by absence of :), assume it is a named range and use the entire criteria
' absent the above conditions, assume the criteria is a range on the Data sheet
If InStr(1, vCriteria(i), "!") > 0 Or InStr(1, vCriteria(i), ":") < 1 Then
Set rngValue1 = Range(Trim(vCriteria(i))).Cells(1)
Else
Set rngValue1 = wshData.Range(Trim(vCriteria(i))).Cells(1)
End If
' extract the value for the filter field
vHeaders(j / 2, 1) = rngValue1.Value
' look at the adjacent even-numbered element
' if the criteria contains a double quote, it is a constant
' if it begins with characters (=, <, >) then it is already a complete string
' otherwise, insert =
If InStr(1, vCriteria(j), """") > 0 Then
s = Left(Trim(vCriteria(j)), 1)
If s = "=" Or s = "<" Or s = ">" Then
vHeaders(j / 2, 2) = vCriteria(j)
Else
vHeaders(j / 2, 2) = "=" & vCriteria(j)
End If
Else
' if the criteria does not contain a double-quote, then it is a cell address
' if it is specific to a sheet (determined by presence of !), use that reference
' otherwise, assume that it is a range on the Summary sheet
If InStr(1, vCriteria(j), "!") Then
Set rngValue2 = Range(Trim(vCriteria(j)))
Else
Set rngValue2 = wshSummary.Range(Trim(vCriteria(j)))
End If
' extract the value for the criteria value
vHeaders(j / 2, 2) = rngValue2.Value
End If
Next i
' find the data range to filter
' assume UsedRange of the data sheet is the entirety of rows needed to filter
Set rngData = Intersect(wshData.Range("A:" & msLAST_CELL).EntireColumn, wshData.UsedRange)
' delete all fitering data
Set rng = rngData.Columns(rngData.Columns.Count).EntireColumn.Offset(0, 1).Resize(columnsize:=rngData.Parent.Cells.Columns.Count - rngData.Columns.Count)
rng.EntireColumn.Delete
' set up the Criteria range for Advanced Filter, and populate the criteria array
Set rngCriteria = wshData.Range(msLAST_CELL & "1").Offset(0, 2).Resize(UBound(vHeaders, 2) - LBound(vHeaders, 2) + 1, UBound(vHeaders, 1) - LBound(vHeaders, 1) + 1)
rngCriteria.Value = Application.WorksheetFunction.Transpose(vHeaders)
' set up the output range for Advanced Filter
Set rngOutput = wshData.Range(msLAST_CELL & "1").Offset(0, 2 + rngCriteria.Columns.Count + 1)
rngOutput.Value = wshData.Range(msNAMES_COLUMN).Cells(1).Value
' perform the advanced filter operation
rngData.AdvancedFilter xlFilterCopy, rngCriteria, rngOutput, unique:=True
' determine the maximum comment length
' if the length of the comment reaches above this limit, an overflow text is appended at the end of the comment
' the overflow comment indicates how many additional records are not displayed
iLenNotice = Len(msNOTICE_TEXT_LEFT) + Len(msNOTICE_TEXT_RIGHT) + iGetNumLen(rngData.Rows.Count)
iMaxLen = miMAX_COMMENT_LENGTH - iLenNotice
msSource = "sGetNames private function"
' get the output results of Advanced Filter
Set rngResult = Range(rngOutput, rngOutput.End(xlDown))
Set rngResult = rngResult.Offset(1, 0).Resize(rowsize:=rngResult.Rows.Count - 1)
' create the output string with delimited names
j = 0
sGetNames = ""
' look through each cell in the filter result
' if the comment is not too long, add it to the list
' if the name exceeds max comment list, add it to overflow count
For Each rng In rngResult.Cells
sValue = rng.Value
If Len(sValue) + Len(sGetNames) > miMAX_COMMENT_LENGTH Then
j = j + 1
Else
sGetNames = sGetNames & sValue & msNAME_SEPARATOR
End If
Next rng
' delete the last separator
If Len(sGetNames) > 0 Then
sGetNames = Left$(sGetNames, Len(sGetNames) - 1)
End If
' if there is any overflow names that were excluded, append the notice with the total count of excluded positions
If j > 0 Then
sGetNames = sGetNames & msNOTICE_TEXT_LEFT & j & msNOTICE_TEXT_RIGHT
End If
' remove the temporary filter criteria and result fields
rngCriteria.Resize(columnsize:=rngCriteria.Columns.Count + 2).EntireColumn.Delete
End Function
