範囲内のセル内の単語の頻度

Question

私は約50のセルの列を持っています。各セルには、3〜8文のいずれかのテキストブロックが含まれています。

Idは、使用されている単語のリストを入力し、その範囲全体（A1：A50）の頻度を取得するのが好きです。

Iveは他の投稿で見つかった他のコードを操作しようとしましたが、複数の単語ではなく1つの単語を含むセルに合わせて調整されているようです。

これは私が使用しようとしていたコードです。

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のイプサムのテキストのいくつかの長いブロックで私のために動作します）試してみてください：すべてのとは対照的に、私は、あなただけのデータを持っている50個の細胞で見にそれを降ろした

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 

をその列には100万を超える。私はまた、rがRangeの代わりにlength 1の配列を取得していた問題を修正しました。 Selectionはアプリケーションですでに定義されているため、 "Selection"の名前を "countRange"に変更したため、名前が正しくありませんでした。

また、コードが "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 

それは辞書を使用していますので、あなたはライブラリへの参照を追加することを確認します（[ツール]> [参照]> [Microsoftスクリプトライブラリを追加します）。また、すべてを小文字にする - 古いコードの大きな問題は、大文字と小文字のバージョンを正しくカウントしなかったことです。つまり、多くの単語が欠落していました。これを望まない場合は、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