Question

我是Excel VBA代码的新手，我需要帮助优化此代码。它完全符合我的要求，但运行时间差不多30秒，最终用户无法接受。

目的是评估单词用作输入句子的频率。在“Raw”表中，第一列是整个句子。第二个是句子中有多少单词的计数。第三百分之一是句子中的第一个，第二个，第三个....一次分析多达1,000个句子。

只有在它们是唯一的时候才会粘贴到“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

我将假设所有句子都是单行，并且在单词之间包含一个空格。添加名为＆＃34;输出＆＃34;到你的工作簿。在单元格A1中键入标题（例如＆＃34; Word＆＃34;），在单元格B2中键入标题（例如＆＃34; Count＆＃34;）。以下将采用您的句子并输出A列中的单词和B列中单词的计数，然后进行排序，以便最常用的位于顶部。根据您拥有的数据量，这应该花费一两秒钟来运行。

注意：您需要添加对＆＃34; Microsoft Scripting Runtime＆＃34;的引用。库。

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

编辑：

这是我完整的，纯粹的代码。请注意，不会为您的目的更新工作簿和工作表引用。要使用RegExp，您需要添加对＆＃34; Microsoft VBScript正则表达式5.5＆＃34;的引用。图书馆。我使用＆＃34; 5.5＆＃34;，但我确定任何一个都可以用于此。

 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工作表单元格中逐个操作。此方法不会将任何数据拉入RAM存储器（快速）。只需获取感兴趣的列并将它们插入到数组或列表中即可。以与函数相同的方式在列表上操作。这将大大加快它的运作速度。例如，

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列。尽情使用收藏品一段时间来了解它们的工作原理

使用多个循环来优化Excel VBA

2 个答案: