这是我使用数组操作的版本，然后是一些范围操作。
Edit1：我已阅读 pnut 关于仅处理 b 的评论。顺便说一句，这不会处理 a+a
Sub Test()
Dim arr, unq
Dim orng As Range, rng As Range, srng As Range
Dim i As Long, k As Long
Dim check As Boolean: check = False
Dim freq As String
'~~> pass range data to array
Set orng = Sheet1.Range("A1", _
Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp))
For Each rng In orng
If Not IsArray(arr) Then
arr = Array(RngToArr(rng.Resize(, 3)))
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = RngToArr(rng.Resize(, 3))
End If
Next
'~~> pass unique combination and count to another array
For i = LBound(arr) To UBound(arr)
If IsEmpty(unq) Then
ReDim unq(1 To 2, 1 To 1)
unq(1, 1) = arr(i)
unq(2, 1) = unq(2, 1) + 1
Else
For k = LBound(unq, 2) To UBound(unq, 2)
If CompArr(arr(i), unq(1, k)) Then
check = False
unq(2, k) = unq(2, k) + 1
Exit For
Else
check = True
End If
Next
If check Then
ReDim Preserve unq(1 To 2, 1 To UBound(unq, 2) + 1)
unq(1, UBound(unq, 2)) = arr(i)
unq(2, UBound(unq, 2)) = unq(2, UBound(unq, 2)) + 1
End If
End If
Next
'~~> Transpose and tidy up the array
ReDim tally(1 To UBound(unq, 2), 1 To 2)
For i = LBound(unq, 2) To UBound(unq, 2)
tally(i, 1) = Join$(unq(1, i), "+")
tally(i, 2) = unq(2, i)
Next
'~~> sort in worksheet, easier than sorting array
With Sheet1
Set srng = .Range("E1:F" & UBound(tally, 1))
srng = tally
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=srng.Offset(0, 1).Resize(, 1), _
SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With .Sort
.SetRange srng
.Header = xlGuess
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'~~> do some manipulation to make it closer to what you want
For Each rng In srng.Offset(0, 1).Resize(, 1)
Select Case rng.Value
Case 1: freq = "found once"
Case 2: freq = "found twice"
Case Else: freq = "found " & rng.Value & " times"
End Select
rng.Value = freq
Next
End Sub
Private Function CompArr(list1, list2) As Boolean
Dim j As Long: CompArr = True
For j = LBound(list1) To UBound(list1)
With Application
If IsError(.Match(list1(j), list2, 0)) _
Then CompArr = False
End With
Next
End Function
Private Function RngToArr(r As Range) As Variant
Dim c As Range, a
For Each c In r
If Len(c.Value) <> 0 Then
If Not IsArray(a) Then
a = Array(c.Value)
Else
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.Value
End If
End If
Next
RngToArr = a
End Function
结果：
不完全是您想要的方式，我无法提出如何动态设置第一名、第二名等。
另外，我没有深入研究加号（+）。如果有空格，结果可能是 +b+c，或 a+c+ 或 a++c。
无论如何，HTH。