查找某个字符在一系列单元格中的单个单元格中出现的次数

Question

我正在尝试返回工作表列的单个单元格中出现的名称数量。
该列中的每个单元格可以有任意数量的名称。
每个名称均由管道“|”分隔，因此我对管道进行计数，然后加一以获取每个单元格中的名称数量。

例如：单元格值为“Bob | Jon | Larry”= 2 个管道 + 1 = 3 个名称。

我的代码可以工作，但我需要对数万条记录执行此操作。我认为我的解决方案不好或有效。

1. 是否有更好的方法，例如不循环遍历范围内的每个单元格？

2. 如果没有不同的方法，如何避免在新列的单元格中打印名称计数？
   我可以将这些值存储在数组中并计算数组的最大值吗？

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

最大子串数

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

接近公式的方法

组合工作表函数

CountA()

和

FilterXML()

可以获取由竖线字符分隔的所有子字符串计数

|

:

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

提示： 如果您想在公式作业中包含完全限定的工作簿 + 工作表参考，您甚至可以按如下方式缩短代码。只需在

External:=True

中使用附加参数

.Address

（例如导致类似

'[Test.xlsm]Sheet1'!A2

的结果）：

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

可能的调用示例

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

更多链接

C.f. JvdV 的百科全书式网站展示了使用的各种可能性

FilterXML()

Answer 3

VBasic2008 的精彩回答。我想我会把它纯粹看作是我自己的编码练习。以下替代方案仅用于利息。

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