Optomizing Excel VBA mit mehreren Schleifen

Question

Ich bin neu in Excel VBA-Code, und ich brauche Hilfe, diesen Code zu optimieren. Es macht genau das, was ich möchte, dauert aber fast 30 Sekunden, was für die Endbenutzer nicht akzeptabel ist.

Der Zweck ist zu beurteilen, wie oft ein Wort mit Eingaben als Sätze verwendet wird. Im Blatt "Raw" ist die erste Spalte der ganze Satz. Die zweite ist eine Zählung, wie viele Wörter in dem Satz sind. Und die dritte 100. sind das erste, zweite, dritte .... Wort im Satz. Bis zu 1.000 Sätze werden gleichzeitig analysiert.

Es wird dann nur in die erste Spalte von "OneColumn" eingefügt, wenn sie eindeutig sind. Ich habe versucht, alles einzufügen und dann Duplikate zu entfernen, aber das dauerte ungefähr 45 Sekunden.

Ich bin sicherlich offen für andere Möglichkeiten zu analysieren, wie oft ein Wort verwendet wird, aber ich konnte nicht herausfinden, wie es in den Zellen zum Zählen zu überprüfen, ohne sie zu brechen.

Ich würde jede Hilfe sehr schätzen.

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

Ich gehe davon aus, dass alle Sätze einzeilig sind und ein Leerzeichen zwischen Wörtern enthalten. Fügen Sie Ihrer Arbeitsmappe ein Blatt mit dem Namen "Output" hinzu. In Zelle A1 geben Sie einen Header ein (zB "Word") und in den Zellen B2 geben Sie einen Header ein (zB "Count"). Das Folgende nimmt Ihre Sätze und gibt die Wörter in Spalte A und die Anzahl der Wörter in Spalte B aus und sortiert dann so, dass das am häufigsten verwendete Wort ganz oben steht. Je nachdem, wie viele Daten Sie haben, sollte dies ein oder zwei Sekunden dauern.

Hinweis: Sie müssen einen Verweis auf die Bibliothek "Microsoft Scripting Runtime" hinzufügen.

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:

Hier ist mein voller, unverfälschter Code. Beachten Sie, dass die Arbeitsmappe und die Blattverweise für Ihren Zweck nicht aktualisiert werden. Um RegExp zu verwenden, müssen Sie einen Verweis auf die Bibliothek "Microsoft VBScript Regular Expressions 5.5" hinzufügen. Ich benutze "5.5", aber ich bin mir sicher, dass irgendjemand dafür arbeiten wird.

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

Ihre Funktion dauert so lange, weil Sie innerhalb der Excel Zelle für Zelle arbeiten. Diese Methode zieht keine Daten in den RAM-Speicher (Fast). Nehmen Sie einfach die gewünschten Spalten und fügen Sie sie in ein Array oder eine Liste ein. Arbeiten Sie in der Liste auf dieselbe Weise wie Ihre Funktion. Dies wird den Betrieb drastisch beschleunigen. Zum Beispiel ist

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 eine Sammlung von Arrays, die Sie die Worte des Satzes in einer nach dem anderen statt 3,4,5 ... 100. Spalte setzen. Spielen Sie eine Weile mit den Sammlungen herum, um zu verstehen, wie sie funktionieren