Частота слов в ячейках в пределах диапазона

Question

У меня есть столбец около 50 ячеек. Каждая ячейка содержит блок текста, где угодно от 3-8 предложений.

Id нравится заполнять список используемых слов и получать их частоты для всего диапазона (A1: A50).

Ive пытался манипулировать другими кодами, которые я нашел в других сообщениях, но они, похоже, предназначены для ячеек, содержащих одно слово, а не несколько слов.

Это код, который я нашел, что я пытался использовать.

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 Ipsum текста):

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 ячеек, в которых у вас есть данные, в отличие от всех > 1 миллион в этой колонке. Я также исправил проблему, когда r получал массив длиной 1 вместо диапазона. И я переименовал «Selection» в «countRange», потому что Selection уже определен в приложении, так что это было плохое имя.

Также обратите внимание, что ваш код тянется от «Sheet1» и выводится в столбцы B и C «Sheet2». Убедитесь, что вы переименовали свои листы или отредактировали эти значения, или вы получите ошибки/повреждение данных.

---

Это, как я бы подойти к решению проблемы:

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 

Он использует словарь, поэтому убедитесь, что вы добавить ссылку на библиотеку (Tools> Add Reference> Microsoft Scripting Library). Это также заставляет все делать строчные буквы - одна большая проблема старого кода заключалась в том, что он не учитывал капитализированные и некапитализированные версии правильно, то есть он пропускал много слов. Удалите 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