Оптимизация Excel VBA с несколькими циклами

Question

Я новичок в коде Excel VBA, и мне нужна помощь в оптимизации этого кода. Он делает именно то, что я хочу, но это займет почти 30 секунд, что не будет приемлемо для конечных пользователей.

Цель состоит в том, чтобы оценить, как часто используется слово с вложенными предложениями. В листе «Сырье» первая колонка - это все предложение. Во-вторых, количество слов в предложении. И третье-100-е - первое, второе, третье ... слово в предложении. Одновременно анализируется до 1000 предложений.

Затем он вставляется в первый столбец «OneColumn», только если они уникальны. Я пробовал вставлять все, а затем удалять дубликаты, но это продолжалось около 45 секунд.

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

Я был бы очень признателен за любую помощь.

Option Explicit 

Sub ListUniqueWords() 
Dim i As Integer 
Dim j As Integer 
Dim k As Integer 

Dim StartTime As Double 
Dim SecondsElapsed As Double 
    StartTime = Timer 

i = 2 
j = 3 
k = 2 

'i=row j=column k=paste into row 

    Do While i < 1001 
    j = 3 
      Do While j < 103 
          If Sheets("Raw").Cells(i, j).Value <> "" And Sheets("Raw").Cells(i, j).Value <> " " And Sheets("OneColumn").Range("A2:A2000").Find(Sheets("Raw").Cells(i, j), LookAt:=xlWhole) Is Nothing Then 
            Worksheets("Raw").Activate 
            Cells(i, j).Select 
            Selection.Copy 
            Worksheets("OneColumn").Activate 
            Cells(k, 1).Activate 
            ActiveCell.PasteSpecial Paste:=xlPasteValues 
            k = k + 1 
            j = j + 1 
           Else 
            j = j + 1 
           End If 
      Loop 
      i = i + 1 
    Loop 
SecondsElapsed = Round(Timer - StartTime, 2) 
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation 

End Sub 

Answer 1

Я собираюсь предположить, что все предложения являются одной строкой и содержат одно пробел между словами. Добавьте в свою книгу лист «Вывод». В ячейке A1 введите заголовок (ex «Word») и в ячейках B2 введите заголовок (ex «Count»). Следующее выведет ваши предложения и выведет слова в столбце A и количество слов в столбце B, а затем сортирует, так что наиболее часто используется наверху. В зависимости от того, сколько данных у вас есть, это займет секунду или два.

Примечание: вам нужно будет добавить ссылку на библиотеку времени выполнения Microsoft Scripting Runtime.

Sub Example() 
Dim X As Variant, S As Variant, key As Variant 
Dim str As String 
Dim oDict As Scripting.Dictionary 
Dim i As Double, j As Double, k As Double 
Dim Anchor As Range 

Set oDict = New Scripting.Dictionary 

With ThisWorkbook 
    'Clear past output 
    With .Sheets("Output") 
     .Range("a2:" & .Cells(.Rows.Count, .Columns.Count).Address).ClearContents 
    End With 

'Fill array with text to search 
    With .Sheets("Raw") 
     X = .Range("a2:a" & .Range("a" & .Rows.Count).End(xlUp).Row).Value2 
    End With 
End With 

For i = LBound(X,1) To UBound(X,1) 
    S = Split(X(i,1), " ") 

    For j = LBound(S, 1) To UBound(S, 1) 
     If oDict.Exists(S(j)) Then 
      oDict.Item(S(j)) = oDict.Item(S(j)) + 1 
     Else 
      oDict.Add S(j), 1 
     End If 
    Next j 
Next i 

'Output results to sheet "Output" 
With ThisWorkbook.Sheets("Output") 
For Each key In oDict.Keys 
    Set Anchor = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0) 
    Anchor = key 
    Anchor.Offset(0, 1) = oDict.Item(key) 
Next key 

.Range("a1:" & .Range("a" & .Rows.Count).End(xlUp).Offset(0, 1).Address).Sort .Range("b:b"), xlDescending 
End With 

End Sub 

EDIT:

Вот мой полный, чистейший код. Обратите внимание, что ссылки на рабочую книгу и листы не обновляются для вашей цели. для использования RegExp вам нужно будет добавить ссылку на библиотеку Microsoft VBScript Regular Expressions 5.5. Я использую «5.5», но я уверен, что для этого все будет работать.

Sub Example() 
Dim X As Variant, S As Variant, S2 As Variant, S3 As Variant, key As  Variant 
Dim oDict As Scripting.Dictionary 
Dim i As Double, j As Double, k As Double 
Dim Anchor As Range 
Dim oReg As New RegExp 
Dim str As String 
Dim st As Single 

Application.ScreenUpdating = False 


st = Timer 
Set oDict = New Scripting.Dictionary 

With ThisWorkbook 
'Clear past output 
    With .Sheets("Output") 
     .Range("a2:" & .Cells(.Rows.Count, .Columns.Count).Address).ClearContents 
    End With 

    'Fill array with text to search 
    With .Sheets("Input") 
     X = .Range("a2:a" & .Range("a" & .Rows.Count).End(xlUp).Row).Value2 
    End With 
End With 

With oReg 
    .Global = True 
    .IgnoreCase = True 
    .Pattern = "[^\w\s]" 
End With 

For i = LBound(X, 1) + 1 To UBound(X, 1) 
    'Get rid of none letter and white space 
      str = oReg.Replace(X(i, 1), "") 


    S = Split(str, " ") 

    For j = LBound(S, 1) To UBound(S, 1) 
     If oDict.Exists(LCase(S(j))) Then 
      oDict.Item(LCase(S(j))) = oDict.Item(LCase(S(j))) + 1 
     Else 
      oDict.Add LCase(S(j)), 1 
     End If 
    Next j 
Next i 

'Output results to sheet "Output" 
With ThisWorkbook.Sheets("Output") 
    For Each key In oDict.Keys 
     Set Anchor = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0) 
     Anchor = key 
     Anchor.Offset(0, 1) = oDict.Item(key) 
    Next key 

     .Range("a1:" & .Range("a" & .Rows.Count).End(xlUp).Offset(0, 1).Address).Sort .Range("b:b"), xlDescending 
End With 

Debug.Print Timer - st 

Application.ScreenUpdating = True 
End Sub 

Answer 2

Ваша функция занимает много времени, так как вы работаете в ячейке листа Excel. Этот метод не выводит данные в оперативную память (Fast). Просто возьмите интересующие столбцы и вставьте их в массив или список. Действуйте в списке так же, как и ваша функция. Это значительно ускорит его работу. Например,

Dim Whole_Sentence_List As New Collection 
Dim Word_Count_List As New Collection 
Dim Array_of_Words_List As New Collection 

Array_of_Words_List представляет собой совокупность массивов, которые вы можете поставить слова в предложении по одному вместо 3,4,5 ... 100 Колонка. Играйте с коллекциями некоторое время, чтобы понять, как они работают.