Vba 计算包含大量文本的Excel列中最常用的单词数？

我有一个大的电子表格，我想对一个特定的列进行字数统计，找出最常用的单词。此列包含大量数据和文本

例如，“员工爬上梯子从顶部货架上取回商品。梯子开始摇晃，员工失去平衡并摔倒。右腿受伤”。像这样的记录大约有1000种。我希望使用数据透视表来找出本专栏中所有单元格中最常用的单词

我不知道该怎么做。有人能帮忙做这件事吗

当前正在使用以下代码：

Option Explicit

Sub MakeWordList()
    Dim InputSheet As Worksheet
    Dim WordListSheet As Worksheet
    Dim PuncChars As Variant, x As Variant
    Dim i As Long, r As Long
    Dim txt As String
    Dim wordCnt As Long
    Dim AllWords As Range
    Dim PC As PivotCache
    Dim PT As PivotTable

    Application.ScreenUpdating = False
    Set InputSheet = ActiveSheet
    Set WordListSheet = Worksheets.Add(after:=Worksheets(Sheets.Count))
    WordListSheet.Range("A1") = "All Words"
    WordListSheet.Range("A1").Font.Bold = True
    InputSheet.Activate
    wordCnt = 2
    PuncChars = Array(".", ",", ";", ":", "'", "!", "#", _
        "$", "%", "&", "(", ")", " - ", "_", "--", "+", _
        "=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*")
    r = 1

'   Loop until blank cell is encountered
    Do While Cells(r, 1) <> ""
'       covert to UPPERCASE
        txt = UCase(Cells(r, 1))
'       Remove punctuation
        For i = 0 To UBound(PuncChars)
            txt = Replace(txt, PuncChars(i), "")
        Next i
'       Remove excess spaces
        txt = WorksheetFunction.Trim(txt)
'       Extract the words
        x = Split(txt)
        For i = 0 To UBound(x)
            WordListSheet.Cells(wordCnt, 1) = x(i)
            wordCnt = wordCnt + 1
        Next i
    r = r + 1
    Loop

'   Create pivot table
    WordListSheet.Activate
    Set AllWords = Range("A1").CurrentRegion
    Set PC = ActiveWorkbook.PivotCaches.Add _
        (SourceType:=xlDatabase, _
        SourceData:=AllWords)
    Set PT = PC.CreatePivotTable _
        (TableDestination:=Range("C1"), _
        TableName:="PivotTable1")
    With PT
        .AddDataField .PivotFields("All Words")
        .PivotFields("All Words").Orientation = xlRowField
    End With
End Sub

选项显式
子MakeWordList（）
将输入表作为工作表进行调整
将单词列表表设置为工作表
变型为暗蓬卡，变型为x
暗淡的i一样长，r一样长
以字符串形式显示文本
模糊的词
将所有单词作为范围
Dim PC作为数据透视缓存
数据透视表
Application.ScreenUpdating=False
设置InputSheet=ActiveSheet
Set WordListSheet=Worksheets.Add（后面：=Worksheets（Sheets.Count））
WordListSheet.Range（“A1”）=“所有单词”
WordListSheet.Range（“A1”）.Font.Bold=True
输入表。激活
wordCnt=2
PuncChars=数组（“.”、“，”、“；”、“：”、“'”、“！”、“#”_
"$", "%", "&", "(", ")", " - ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*")
r=1
'循环，直到遇到空白单元格
“当单元格（r，1）”时执行”
“改为大写
txt=UCase（单元格（r，1））
'删除标点符号
对于i=0至UBound（PuncChars）
txt=替换（txt，PuncChars（i），“”）
接下来我
'删除多余的空格
txt=工作表函数.Trim（txt）
"摘抄文字,
x=拆分（txt）
对于i=0到UBound（x）
WordListSheet.Cells（wordCnt，1）=x（i）
wordCnt=wordCnt+1
接下来我
r=r+1
环
'创建数据透视表
WordListSheet.Activate
设置所有字=范围（“A1”）。当前区域
设置PC=ActiveWorkbook.PivotCaches.Add_
（SourceType:=xlDatabase_
SourceData:=所有字）
设置PT=PC.CreatePivotTable_
（表目的地：=范围（“C1”）_
TableName:=“数据透视表1”）
与PT
.AddDataField.PivotFields（“所有单词”）
.PivotFields（“所有单词”）.Orientation=xlRowField
以
端接头

这里有一个快速而肮脏的宏（我今天觉得特别有用）。将其放入工作簿模块中。注意：我假设您将激活的工作表是A列中包含所有文本的工作表

Sub Test()
Dim lastRow&, i&, tempLastRow&
Dim rawWS As Worksheet, tempWS As Worksheet

Set rawWS = ActiveSheet
Set tempWS = Sheets.Add
tempWS.Name = "Temp"
rawWS.Activate

'tempWS.Columns(1).Value = rawWS.Columns(1).Value
tempLastRow = 1

With rawWS
    .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                                  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
                                  Semicolon:=False, Comma:=False, Space:=True, Other:=False, TrailingMinusNumbers:=True

    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = lastRow To 1 Step -1
        .Rows(i).EntireRow.Copy
        tempWS.Range("A" & tempLastRow).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        ' tempWS.Range ("A" & tempLastRow)
        tempLastRow = tempWS.Cells(tempWS.Rows.Count, 1).End(xlUp).Row + 1
    Next i
    Application.CutCopyMode = False
End With

With tempWS
    ' Now, let's get unique words and run a count
    .Range("A:A").Copy .Range("C:C")
    .Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
    tempLastRow = .Cells(.Rows.Count, 3).End(xlUp).Row

    .Range(.Cells(1, 4), .Cells(tempLastRow, 4)).FormulaR1C1 = "=COUNTIF(C[-3],RC[-1])"
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("D1:D1048576") _
                              , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Range("C1:D1048576")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End With

End Sub

基本上，它创建一个新的工作表，统计所有单个单词，并将单词（和计数）放入一列中，按最常用的单词排序。您可以根据需要进行调整

---

注意：我在添加代码之前做了这个。它不会创建透视表，但据我所知，如果您只需要最常用的单词，透视表就太过分了。但是，如果您需要任何编辑或更改，请告诉我

这里有一个例程来显示每个单词及其出现的次数（使用

Split

和

Collection

s）

用法：

CountTheWordsInRange（“A1:A4”）

结果:

---

每个单元格有一个单词吗？还是每个单元格都有一定数量的单词？每个单元格都有一定数量的单词。例如，我给出的关于员工从梯子上摔下来的示例仅在一个单元格中。使用VBA宏并不困难。您是否同意这种方法？？虽然我正在尝试学习，但使用VBA并不特别舒服。我已经在上面添加了我目前正在使用的代码。我注意到了一些好的解决方案。如果你实现下面的任何一个想法，你可能会考虑结合一些东西来消除标点符号，并确保事情是大写的，就像你的原始代码一样。如果您喜欢其中一个解决方案，并且遇到问题，也许您可以要求他们将其添加到代码中。是否可以修改此代码，使其拆分为3个单词而不是一个单词？比如“Hello said the”在你的例子中会被算作2。我正在努力消除像他、我、它、和等这样的常用词。我觉得把3个词加在一起更适合识别模式。谢谢@泰迪斯，这是可行的，但我很好奇你想怎么说。例如，如果第一个返回的是

Hello说的是

，而

说的是厨师说的是

？我想最好的方法是一起搜索相同的3个单词，但我整天都在考虑这个问题，我认为这将非常复杂，而且可能需要很长时间才能运行，特别是我每次运行这个宏时解析的数据量。您好，我正在尝试运行您的代码，您是想注释掉两段代码

'tempWS.Columns（1）.Value=rawWS.Columns（1）.Value

和

'tempWS.Range（“A”&tempLastRow）

？当我运行带有注释掉的那些部分的代码时，我在temp-WS中没有得到任何结果，当我从这两个部分中删除注释时，我在tempWS.Range（“A”&tempLastRow）行上得到错误“Invalid use of property”，当我只删除第一条注释时，代码将运行，但不会正确计算字数。@Tydis-我写这篇文章已经有一段时间了-但是是的，

tempWS.Range（“a”&tempLastRow）

行应该被注释掉。你在那里得到了一个错误，因为那条线实际上没有做任何事情。（我忘了我为什么要把它包括进去，即使被注释掉了）。如果需要临时工作表中的数据，则不应注释掉

tempWS…Value=rawWS…Value

。正如您所指出的，如果没有它，您在Temp WS的A列中就没有任何信息可供实际复制……当您运行它时，它如何正确地计算字数？它是给出了错误，还是仅仅提供了一个不正确

Sub CountTheWordsInRange(RangeToCheck As Range)

Dim wordList As New Collection
Dim keyList As New Collection
Dim c
For Each c In RangeToCheck
    Dim words As Variant
    words = Split(c, " ") 'Pick a delimiter
    For Each w In words
        Dim temp
        temp = -1
        On Error Resume Next
        temp = wordList(w)
        On Error GoTo 0
        If temp = -1 Then
            wordList.Add 1, Key:=w
            keyList.Add w, Key:=w
        Else
            wordList.Remove (w)
            keyList.Remove (w)
            wordList.Add temp + 1, w
            keyList.Add w, Key:=w
        End If
    Next w
Next c
'Here we can display the word counts
'KeyList is a collection that contains each word
'WordList is a collection that contains each amount
Dim x
For x = 1 To wordList.Count
    With Sheets("Sheet1")
        .Cells(x, "E").Value = keyList(x)  'Display Word in column "E"
        .Cells(x, "F").Value = wordList(x) 'Display Count in column "F"
    End With
Next x

End Sub