範圍內的單元格內的單詞頻率

Question

我有一列約50個單元格。每個單元格包含一個文本塊，可以包含3-8個句子。

我喜歡填寫正在使用的單詞列表並獲取整個範圍（A1：A50）的頻率。

我試圖操縱我在其他帖子中發現的其他代碼，但它們似乎是針對包含一個單詞而非多個單詞的單元格進行量身定製的。

這是我發現我試圖使用的代碼。

Sub Ftable() 
Dim BigString As String, I As Long, J As Long, K As Long 
Dim Selection As Range 

Set Selection = ThisWorkbook.Sheets("Sheet1").Columns("A") 
BigString = "" 
For Each r In Selection 
    BigString = BigString & " " & r.Value 
Next r 
BigString = Trim(BigString) 
ary = Split(BigString, " ") 
Dim cl As Collection 
Set cl = New Collection 
For Each a In ary 
    On Error Resume Next 
    cl.Add a, CStr(a) 
Next a 

For I = 1 To cl.Count 
    v = cl(I) 
    ThisWorkbook.Sheets("Sheet2").Cells(I, "B").Value = v 
    J = 0 
    For Each a In ary 
     If a = v Then J = J + 1 
    Next a 
    ThisWorkbook.Sheets("Sheet2").Cells(I, "C") = J 
Next I 
End Sub 

Answer 1

試試這個（對我的作品有Lorem存有文本的某些長塊）：

Sub Ftable() 
Dim BigString As String, I As Long, J As Long, K As Long 
Dim countRange As Range 

Set countRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A50") 
BigString = "" 
For Each r In countRange.Cells 
    BigString = BigString & " " & r.Value 
Next r 
BigString = Trim(BigString) 
ary = Split(BigString, " ") 
Dim cl As Collection 
Set cl = New Collection 
For Each a In ary 
    On Error Resume Next 
    cl.Add a, CStr(a) 
Next a 

For I = 1 To cl.Count 
    v = cl(I) 
    ThisWorkbook.Sheets("Sheet2").Cells(I, "B").Value = v 
    J = 0 
    For Each a In ary 
     If a = v Then J = J + 1 
    Next a 
    ThisWorkbook.Sheets("Sheet2").Cells(I, "C") = J 
Next I 
End Sub 

我把它歸結爲只是看着，你有數據的50個細胞，而不是全部該專欄中的100萬。我還修復了一個問題，其中r的長度是1而不是Range。我將「Selection」重命名爲「countRange」，因爲Selection已經在應用程序中定義，所以命名不好。

此外，請注意，您的代碼從「Sheet1」拉出並輸出到「Sheet2」的列B和C中。確保您重命名工作表或編輯這些值，否則您將收到錯誤/數據損壞。

---

這是我會處理這個問題：

Sub Ftable() 
Dim wordDict As New Dictionary 
Dim r As Range 
Dim countRange As Range 
Dim str As Variant 
Dim strArray() As String 

Set countRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A50") 

For Each r In countRange 
    strArray = Split(Trim(r.Value), " ") 

    For Each str In strArray 
     str = LCase(str) 
     If wordDict.Exists(str) Then 
      wordDict(str) = wordDict(str) + 1 
     Else 
      wordDict.Add str, 1 
     End If 
    Next str 
Next r 

Set r = ThisWorkbook.Sheets("Sheet2").Range("B1") 
For Each str In wordDict.Keys() 
    r.Value = str 
    r.Offset(0, 1).Value = wordDict(str) 
    Set r = r.Offset(1, 0) 
Next str 

Set wordDict = Nothing 
End Sub 

它使用一本字典，所以一定要確保你的引用添加到庫中（工具>添加引用>微軟腳本庫）。它也迫使所有事情都要小寫 - 舊代碼的一大問題是它沒有正確計算大寫和未加數字的版本，這意味着它錯過了很多單詞。如果你不想要這個，請刪除str = LCase(str)。

獎勵：這個方法在我的測試表上跑了大約8倍。

Answer 2

在這裏，一本字典是處理這個問題的最佳方法，我認爲你可以測試字典是否已經包含一個項目。如果有任何你沒有得到的東西，請回復。

Sub CountWords() 

Dim dictionary As Object 
Dim sentence() As String 
Dim arrayPos As Integer 
Dim lastRow, rowCounter As Long 
Dim ws, destination As Worksheet 

Set ws = Sheets("Put the source sheet name here") 
Set destination = Sheets("Put the destination sheet name here") 

rowCounter = 2 
arrayPos = 0 
lastRow = ws.Range("A1000000").End(xlUp).Row 

Set dictionary = CreateObject("Scripting.dictionary") 

For x = 2 To lastRow 
    sentence = Split(ws.Cells(x, 1), " ") 
    For y = 0 To UBound(sentence) 
     If Not dictionary.Exists(sentence(y)) Then 
      dictionary.Add sentence(y), 1 
     Else 
      dictionary.Item(sentence(y)) = dictionary.Item(sentence(y)) + 1 
     End If 
    Next y 
Next x 

For Each Item In dictionary 
    destination.Cells(rowCounter, 1) = Item 
    destination.Cells(rowCounter, 2) = dictionary.Item(Item) 
    rowCounter = rowCounter + 1 
Next Item 

End Sub