In VBA find the max number of times a character appears in a single cell out of a range of cells

Question

Before I start, I just want to thank every contributor ahead of time. I've only posted one question before, and I was amazed at how quickly I got responses and how much I learned after studying the solution. I'm hoping I will have enough reputation points soon to start upvoting good solutions I find here.

Anyways, what I'm trying to do is return one number, and that number is the maximum number of names that appear in a single cell of a worksheet column. Each cell in that column can have any number of names in it. Each name is delimited by a pipe "|", so I count the pipes and then add one to get the number of names in each cell. For example: Cell value is "Bob | Jon | Larry" = 2pipes +1 = 3 names.

My code below works, but I need to do this on tens of thousands of records. I don't think my solution is a good or efficient way to do it (tell me if I'm wrong). So my questions are:

1. Is there a better way to accomplish this, such as without looping through every cell in the range?

2. If there isn't a totally different approach to this, how can I avoid actually printing the name counts in cells in a new column? Could I store these values in an array and calculate the max of the array? (maybe there is already a thread on this topic you could point me to?)

Sub charCnt()

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = Worksheets("Leasing")
Dim vRange As Variant
Dim iCharCnt As Integer
Dim iRows As Integer
Dim i As Integer
Dim iMax As Integer

Const sFindChar As String = "|"

iRows = ws.Cells(Rows.Count, "A").End(xlUp).Row 'count number of rows

For i = 1 To iRows
     vRange = Cells(i, "O") 'column O has the names
    iCharCnt = Len(vRange) - Len(Replace(vRange, sFindChar, "")) 'find number of | in single cell.
    ws.Cells(i, "W") = iCharCnt 'column W is an empty column I use to store the name counts
Next i

iMax = Application.WorksheetFunction.Max(Range("W:W")) + 1 'return max from column W
    
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Max number of names in one cell is " & iMax) ' show result

End Sub

Answer 1

Max Number of Substrings

Option Explicit

Sub charCount()

    Const cCol As String = "O"
    Const fRow As Long = 1
    Const Delimiter As String = "|"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Leasing")
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, cCol).End(xlUp).Row
    Dim rg As Range: Set rg = ws.Cells(fRow, cCol).Resize(lRow - fRow + 1)
    Dim Data As Variant: Data = rg.Value
    
    Dim i As Long
    For i = 1 To UBound(Data, 1)
        Data(i, 1) = Len(Data(i, 1)) - Len(Replace(Data(i, 1), Delimiter, ""))
    Next i
    Dim iMax As Long: iMax = Application.Max(Data) + 1
    
    MsgBox ("Max number of names in one cell is " & iMax) ' show result

End Sub

Answer 2

A close-to-formula approach

Combining worksheet functions CountA() and FilterXML() allows to get all substring counts separated by the pipe character |:

Sub CountSubstrings(StartCell As Range, TargetRng As Range)
'Purp.: count items separated by pipes
'Meth.: via worksheetfunction FILTERXML()
'Note:  assumes target in same sheet as StartCell (could be changed easily)

'a) enter formula into entire target range
    Const PATTERN$ = _
        "=IF(LEN($),COUNTA(FILTERXML(""<t><s>""&SUBSTITUTE($,""|"",""</s><s>"")&""</s></t>"",""//s"")),0)"
    TargetRng.Formula2 = Replace(PATTERN, _
        "$", StartCell.Parent.Name & "!" & StartCell.Address(False, False))
'b) optional overwriting of formulae
    'TargetRng = TargetRng.Value
'c) display maximum result
    MsgBox Application.Max(TargetRng)

End Sub

Hint: You can even shorten code as follows if you want to include the fully qualified workbook + worksheet reference in the formula assignment. Just use the additional argument External:=True in .Address (resulting e.g. in something like '[Test.xlsm]Sheet1'!A2):

    TargetRng.Formula2 = Replace(PATTERN, _
        "$", StartCell.Address(False, False, External:=True))

Possible Example call

    With Sheet1
        CountSubstrings .Range("A2"), .Range("D2:D5")
    End With

Further link

C.f. JvdV's encyclopaedia-like site demonstrating the various possibilities to use FilterXML()

Answer 3

Brilliant answer by VBasic2008. I thought I would look at it purely as a coding exercise for myself. Alternative below provided for interest only.

Option Explicit

Sub CountMaxNames()
Dim arr1(), i, j, count As Long, tally As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("leasing")

arr1 = ws.Range("O1:O" & ws.Range("O" & Rows.count).End(xlUp).Row)
count = 0: tally = 0

For Each i In arr1
    For j = 1 To Len(i)
        If Mid(i, j, 1) = "|" Then count = count + 1
    Next j
        count = count + 1
            If count >= tally Then tally = count
        count = 0
Next i

MsgBox "Maximum number of names in one cell is " & tally

End Sub