问如何计算每个单元格中由空格分隔的唯一字符串的数目？

EN

Option Explicit

Function CountUniqueSubStrings( _
    ByVal SplitString As String, _
    Optional ByVal Delimiter As String = " ") _
As Long
    Dim SubStrings() As String: SubStrings = Split(SplitString, Delimiter)
    Dim ssCount As Long: ssCount = UBound(SubStrings)
    Dim usCount As Long
    If ssCount < 1 Then
        usCount = ssCount + 1
    Else
        Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
        Dim cString As String
        Dim n As Long
        For n = 0 To ssCount
            cString = SubStrings(n)
            If Len(cString) > 0 Then
                dict(SubStrings(n)) = Empty
            End If
        Next n
        usCount = dict.Count
    End If
    CountUniqueSubStrings = usCount
End Function

=CountUniqueSubStrings(A1)

Sub CountUniqueSubStringsTEST()
    
    ' Define constants.
    Const sFirst As String = "A2"
    Const dFirst As String = "B2"
    Const Delimiter As String = " "
    
    ' Create a reference to the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet
    ' Maybe better examples:
    'Set ws = Sheet1
    'Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' Create a reference to the Source Column Range.
    Dim srg As Range
    Dim rCount As Long
    With ws.Range(sFirst)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If fCell Is Nothing Then Exit Sub
        rCount = lCell.Row - .Row + 1
        Set srg = .Resize(rCount)
        Debug.Print srg.Address
    End With
    
    ' Write values from the Source Column Range to the Data Array.
    Dim Data As Variant
    If rCount = 1 Then ' one cell only
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
    Else
        Data = srg.Value
    End If
    
    ' Replace the values in the Data Array with the 'unique counts'.
    Dim r As Long
    For r = 1 To rCount
        Data(r, 1) = CountUniqueSubStrings(Data(r, 1), Delimiter)
    Next r
    
    ' Create a reference to the Destination Column Range.
    Dim drg As Range: Set drg = ws.Range(dFirst).Resize(rCount)
    ' Write the 'unique counts' from the Data Array
    ' to the Destination Column Range.
    drg.Value = Data
    ' Clear the contents below the Destination Column Range.
    With drg.Cells(1)
        .Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
            .Offset(rCount).ClearContents
    End With

End Sub