文本字符串中单词的唯一计数

Question

我有一个包含多个字符串的数据集，我想要一个唯一的出现次数，以便我可以查看和优化我的数据集。我一直无法使用公式做到这一点，所以转而使用 VBA，但由于我是业余爱好者，所以遇到了障碍。

我的数据看起来像这样......

我希望它返回这个...

我尝试将文本解析为列，但在大型数据集中，我的字符串中有 60 列，其中有 100 次点击。因此，转置它然后尝试获取唯一性计数将是令人生畏的。

因此，我希望 VBA 会有所帮助，但我似乎只能获得一个函数，而不是使用 Sub 和 Function 来转置然后计数。像下面这样...

Sub Main()
    Dim filename As String
    Dim WorksheetName As String
    Dim CellRange As String
    
    Sheets.Add.Name = "ParsedOutput"

'==============================================================
' CHANGE THESE VALUES FOR YOUR SHEET   
WorksheetName =   
CellRange =    
'==============================================================
   
    ' Get range
    Dim Range
    Set Range = ThisWorkbook.Worksheets(WorksheetName).Range(CellRange)

    ' Copy range to avoid overwrite
    Range.Copy _
        Destination:=ThisWorkbook.Worksheets("ParsedOutput").Range("A1")
        
    ' Get copied exclusions
    Dim Copy
    Set Copy = ThisWorkbook.Worksheets("ParsedOutput").Range("A:A")
    
    ' Parse and overwrite
    Copy.TextToColumns _
        Destination:=Range("A:A"), _
        DataType:=xlDelimited, _
        ConsecutiveDelimiter:=True, _
        Comma:=True

End Sub

Option Explicit

Public Function Counter(InputRange As Range) As String

Dim CellValue As Variant, UniqueValues As New Collection

Application.Volatile

'For error Handling On Error Resume Next

'Looping through all the cell in the defined range For Each CellValue In InputRange
    UniqueValues.Add CellValue, CStr(CellValue)  ' add the unique item Next

'Returning the count of number of unique values CountUniqueValues = UniqueValues.Count

End Function

Answer 1

为了简单起见，我将使用最少的数据来演示如何实现您想要的。随意更改代码以满足您的需要。

Excel 工作表

假设我们的工作表如下所示

逻辑：

1. 找到最后一行和最后一列，如图所示 HERE 并构建您的范围。
2. 将该范围的值存储在一个数组中。
3. 遍历该数组中的每个项目并提取基于, 的单词作为分隔符并将其存储在集合中。如果分隔符不存在，则将整个单词存储在集合中。为了创建一个独特的集合，我们使用On Error Resume Next，如下面的代码所示。
4. 根据集合中的字数，我们创建一个二维数组用于输出。数组的一部分将保存单词，另一部分将保存出现次数。
5. 使用.Find and .FindNext统计范围内某个单词的出现次数，然后将其存储到数组中。
6. 将数组一次性写入相关单元格。出于演示目的，我将写信至 Column D

代码

我已对代码进行了注释，因此您理解它应该不会有问题，但如果您这样做了，请询问。

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    
    '~~> Change this to relevant sheet
    Set ws = Sheet1
    
    Dim LastRow As Long, LastColumn As Long
    Dim i As Long, j As Long, k As Long
    Dim col As New Collection
    Dim itm As Variant, myAr As Variant, tmpAr As Variant
    Dim OutputAr() As String
    Dim aCell As Range, bCell As Range, rng As Range
    Dim countOfOccurences As Long
    
    With ws
        '~~> Find last row
        LastRow = .Cells.Find(What:="*", _
                  After:=.Range("A1"), _
                  Lookat:=xlPart, _
                  LookIn:=xlFormulas, _
                  SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious, _
                  MatchCase:=False).Row
        
        '~~> Find last column
        LastColumn = .Cells.Find(What:="*", _
                     After:=.Range("A1"), _
                     Lookat:=xlPart, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByColumns, _
                     SearchDirection:=xlPrevious, _
                     MatchCase:=False).Column
                     
        '~~> Construct your range
        Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
        
        '~~> Store the value in an array
        myAr = rng.Value2
        
        '~~> Create a unique collection
        For i = LBound(myAr) To UBound(myAr)
            For j = LBound(myAr) To UBound(myAr)
                If Len(Trim(myAr(i, j))) <> 0 Then
                    '~~> Check data has "," delimiter
                    If InStr(1, myAr(i, j), ",") Then
                        tmpAr = Split(myAr(i, j), ",")
                        
                        For k = LBound(tmpAr) To UBound(tmpAr)
                            On Error Resume Next
                            col.Add tmpAr(k), CStr(tmpAr(k))
                            On Error GoTo 0
                        Next k
                    Else
                        On Error Resume Next
                        col.Add myAr(i, j), CStr(myAr(i, j))
                        On Error GoTo 0
                    End If
                End If
            Next j
        Next i
        
        '~~> Count the number of items in the collection
        i = col.Count
        
        '~~> Create output array for storage
        ReDim OutputAr(1 To i, 1 To 2)
        i = 1
        
        '~~> Loop through unique collection
        For Each itm In col
            OutputAr(i, 1) = Trim(itm)
            countOfOccurences = 0
            
            '~~> Use .Find and .Findnext to count for occurences
            Set aCell = rng.Find(What:=OutputAr(i, 1), LookIn:=xlValues, _
                Lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
        
            If Not aCell Is Nothing Then
                Set bCell = aCell
                countOfOccurences = countOfOccurences + 1
                Do
                    Set aCell = rng.FindNext(After:=aCell)
        
                    If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        countOfOccurences = countOfOccurences + 1
                    Else
                        Exit Do
                    End If
                Loop
            End If
            
            '~~> Store count in array
            OutputAr(i, 2) = countOfOccurences
            i = i + 1
        Next itm
        
        '~~> Output it to relevant cell
        .Range("D1").Resize(UBound(OutputAr), 2).Value = OutputAr
    End With
End Sub

输出

Answer 2

以下是粗略的方法，is open to tons of improvements，但应该可以帮助您入门。

阅读 cmets 并调整代码以满足您的需求。

Option Explicit


Public Sub CountWordsInColumn()
    
    ' Adjust to set the sheet holding the data
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("DataSet")
    
    ' Adjust the column and row that contains the hits
    Dim hitsColumn As String
    Dim hitsStartRow As Long
    Dim lastRow As Long
    hitsColumn = "C"
    hitsStartRow = 2
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, hitsColumn).End(xlUp).Row
    
    ' Adjust the column that contains the hits
    Dim sourceRange As Range
    Set sourceRange = sourceSheet.Range(hitsColumn & hitsStartRow & ":" & hitsColumn & lastRow)
    
    ' Add values in each cell split by ,
    Dim evalCell As Range
    Dim splitValues As Variant
    Dim counter As Long
    ReDim splitValues(lastRow - hitsStartRow)
    For Each evalCell In sourceRange
    
        splitValues(counter) = Split(evalCell.Value, ",")
        
        counter = counter + 1
        
    Next evalCell
    
    ' Get all values into an array
    Dim allValues As Variant
    allValues = AddValuesToArray(splitValues)
    
    ' Get unique values into an array
    Dim uniqueValues As Variant
    uniqueValues = GetUniqueValues(allValues)
    
    ' Count duplicated values from unique array
    Dim outputData As Variant
    outputData = CountValuesInArray(uniqueValues, allValues)
    
    ' Add new sheet
    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Sheets.Add
    PrintArrayToSheet outputSheet, outputData

End Sub

Private Function AddValuesToArray(ByVal myArray As Variant) As Variant

    Dim counter As Long
    Dim tempArray As Variant
    Dim tempCounter As Long
    Dim tempArrayCounter As Long
    
    ReDim tempArray(0)
    
    For counter = 0 To UBound(myArray)
        
        For tempCounter = 0 To UBound(myArray(counter))
            
            tempArray(tempArrayCounter) = myArray(counter)(tempCounter)
            
            tempArrayCounter = tempArrayCounter + 1
            
            ReDim Preserve tempArray(tempArrayCounter)
        
        Next tempCounter
    
    Next counter
    
    ReDim Preserve tempArray(tempArrayCounter - 1)
    
    AddValuesToArray = tempArray

End Function

Private Function GetUniqueValues(ByVal tempArray As Variant) As Variant
    Dim tempCol As Collection
    Set tempCol = New Collection
    
    On Error Resume Next
    Dim tempItem As Variant
    For Each tempItem In tempArray
        tempCol.Add tempItem, CStr(tempItem)
    Next
    On Error GoTo 0
    
    Dim uniqueArray As Variant
    Dim counter As Long
    ReDim uniqueArray(tempCol.Count - 1)
    For Each tempItem In tempCol
        uniqueArray(counter) = tempCol.Item(counter + 1)
        counter = counter + 1
    Next tempItem
    GetUniqueValues = uniqueArray
    
End Function

Function CountValuesInArray(ByVal uniqueArray As Variant, ByVal allValues As Variant) As Variant
    
    Dim uniqueCounter As Long
    Dim allValuesCounter As Long
    Dim ocurrCounter As Long
    Dim outputData As Variant
    
    ReDim outputData(UBound(uniqueArray))
    
    For uniqueCounter = 0 To UBound(uniqueArray)
    
        For allValuesCounter = 0 To UBound(allValues)
        
            If uniqueArray(uniqueCounter) = allValues(allValuesCounter) Then ocurrCounter = ocurrCounter + 1
        
        Next allValuesCounter
        
        ' This is the output
        Debug.Print uniqueArray(uniqueCounter), ocurrCounter
        outputData(uniqueCounter) = Array(uniqueArray(uniqueCounter), ocurrCounter)
        
        ocurrCounter = 0
    
    Next uniqueCounter
    
    CountValuesInArray = outputData
    
End Function

Private Sub PrintArrayToSheet(ByVal outputSheet As Worksheet, ByVal outputArray As Variant)

    Dim counter As Long
    
    For counter = 0 To UBound(outputArray)
    
        outputSheet.Cells(counter + 1, 1).Value = outputArray(counter)(0)
        outputSheet.Cells(counter + 1, 2).Value = outputArray(counter)(1)
    
    Next counter
End Sub

Answer 3

试试，

使用字典提取重复项很方便。

Sub test()
    Dim Ws As Worksheet, wsResult As Worksheet
    Dim vDB, vSplit, v
    Dim Dic As Object 'Scripting.Dictionary
    Dim i As Long, n As Long
    
    Set Dic = CreateObject("Scripting.Dictionary")
    
    Set Ws = Sheets(1) 'ActiveSheet
    vDB = Ws.Range("a1").CurrentRegion
    
    For i = 2 To UBound(vDB, 1)
        vSplit = Split(vDB(i, 3), ",")
        For Each v In vSplit
            If Dic.Exists(v) Then
                Dic(v) = Dic.Item(v) + 1
            Else
                Dic.Add v, 1
            End If
        Next v
    Next i
        
    Set wsResult = Sheets(2)
    n = Dic.Count
    With wsResult
        .UsedRange.Clear
        .Range("a1").Resize(n) = WorksheetFunction.Transpose(Dic.Keys)
        .Range("b1").Resize(n) = WorksheetFunction.Transpose(Dic.Items)
    End With
        
End Sub

Answer 4

适用于所有不会使用 VBA 的人。 这是 PowerQuery 的解决方案：

    Quelle = Excel.CurrentWorkbook(){[Name="tbl_Source"]}[Content],
    Change_Type = Table.TransformColumnTypes(Quelle,{{"ID", Int64.Type}, {"Record", type text}, {"Hits", type text}}),
    Split_Hits = Table.ExpandListColumn(Table.TransformColumns(Change_Type, {{"Hits", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Hits"),
    Clean_Spaces = Table.ReplaceValue(Split_Hits," ","",Replacer.ReplaceText,{"Hits"}),
    Group_Rows = Table.Group(Clean_Spaces, {"Hits"}, {{"Count", each Table.RowCount(_), Int64.Type}})
in
    Group_Rows

Answer 5

模拟较新的TextJoin 和Unique 函数的方法

为了完成上述解决方案，我演示了一种使用方法

• [1]a) 替换 TextJoin 函数（自 2019 年版，MS 365 起可用 ~> 较新的函数代码已被注释掉，顺便说一句），
• [1]b) FilterXML() 函数获取唯一词（自 2013+ 版本起可用）和
• [3]a) 负过滤计算结果

Sub wordCounts()
'[0]define data range
With Sheet3
    Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Dim rng As Range: Set rng = .Range("A2:A" & lastRow)
End With
With WorksheetFunction
'[1]split a) available and b) unique words into arrays
'   Dim words:   words = Split(.TextJoin(",", True, rng), ",")   ' (available vers. 2019+ or MS 365)
    Dim words:   words = Split(Join(.Transpose(rng), ","), ",")  '

    Dim uniques: uniques = UniqueXML(words)                      ' (already since vers. 2013+)
    
'[2]provide for calculation
    'fill temporary array with words
    Dim tmp: tmp = words
    'declare cnt array for counting results
    Dim cnt: ReDim cnt(0 To UBound(uniques), 0 To 0)
    Dim old As Long: old = UBound(tmp) + 1      ' remember original size
'[3]get word counts
    Dim elem
    For Each elem In uniques
        'a) filter out current elem
            tmp = Filter(tmp, elem, False)
            Dim curr As Long: curr = UBound(tmp) + 1
        'b) count number of words (as difference of filtered tmp boundaries) ...
            Dim n As Long: n = old - curr
        '   ... and remember latest array boundary
            old = curr
        'c) assign results to array cnt
            Dim i As Long: cnt(i, 0) = n
            i = i + 1                       ' increment counter
    Next elem
'[4]write word counts to target
    rng.Offset(0, 2).Resize(UBound(uniques), 1) = .Transpose(uniques)
    rng.Offset(0, 3).Resize(UBound(cnt), 1) = cnt
End With

End Sub

帮助功能UniqueXML()

Function UniqueXML(arr, Optional Delim As String = ",", Optional ZeroBased As Boolean = False)
  ' Purp: return unique list of array items
  ' Note: optional argument Delim defaulting to colon (",")
  ' Help: https://docs.microsoft.com/de-de/office/vba/api/excel.worksheetfunction.filterxml
  ' [1] get array data to xml node structure (including root element)
    Dim wellformed As String
    wellformed = "<root><i>" & Join(arr, "</i><i>") & "</i></root>"
  ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ' [2] define XPath string searching unique item values
  ' Note: c.f. udf: https://stackoverflow.com/questions/58677041/vba-excel-how-to-display-non-equal-values-in-an-excel-array/58685756#58685756
  ' ------------------------------------------------
  ' //i                    ... all <i> node values after the DocumentElement
  ' [not( .=preceding::i)] ... only if not preceded by siblings of the same node value
  ' ------------------------------------------------
    Dim myXPath As String
    myXPath = "//i[not( .=preceding::i)]"
   
  ' [3] get "flat" 1-dim array (~> one-based!)
    Dim tmp As Variant
    tmp = Application.Transpose(WorksheetFunction.FilterXML(wellformed, myXPath))
  ' [3a] optional redim as zero-based array
    If ZeroBased Then ReDim Preserve tmp(LBound(tmp) - 1 To UBound(tmp) - 1)
        
  ' [4] return function result
    UniqueXML = tmp
End Function

Answer 6

我不明白您在 sub 或 function 之间遇到的问题；但是，这是一个计算范围内唯一值的函数

    Public Function Counter(InputRange As Variant) As Variant
    
        Dim UniqueValues As New Collection
        Dim Val As Variant
        Dim Cell As Range
        Dim I As Long
        
        Application.Volatile
        
        On Error Resume Next
        For Each Cell In InputRange
            Val = Split(Cell, ",")
            If IsArray(Val) Then
                For I = LBound(Val) To UBound(Val)
                    UniqueValues.Add Val(I), CStr(Val(I))
                Next I
            Else
                UniqueValues.Add Val, CStr(Val)
            End If
        Next Cell
        On Error GoTo 0
        Counter = UniqueValues.Count
    
    End Function