VBA中的单词出现:如何加速 [英] Word occurences in VBA: how to speed up
问题描述
我需要编写一个 MS Word 宏来计算给定文档中每个单词的出现次数,并打印出像 .我做了宏并且它有效,但是它太慢了,需要几个小时才能获得 60000 字的文档的结果.你能给我一些关于如何让宏运行得更快的意见/建议吗?
I need to write a MS Word macro to count occurence of every word within a given document and print out the list like . I did the macro and it works, but it is so sloooow, it takes several hours to get results for a document of 60000 words. Could you please give me some advices/suggestions on how to make the macro run faster?
(我在这里检查了一个类似的问题 WORD VBA Count Word Occurrences 但仍然不不知道如何加速并需要检查我的宏).谢谢.
(I checked a similar question here WORD VBA Count Word Occurrences but still don't get it how to speed up and need my macro to be reviewed). Thank you.
Private Type WordStatData
WordText As String
WordCount As Integer
End Type
Option Base 1
'Check if the word is valid
Private Function IsValidWord(SomeString As String) As Boolean
Dim Retval As Boolean
Retval = True
If Not (InStr(SomeString, " ") = 0) Then Retval = False
If Not (InStr(SomeString, ".") = 0) Then Retval = False
If Not (InStr(SomeString, ",") = 0) Then Retval = False
If Not InStr(SomeString, "0") = 0 Then Retval = False
If Not InStr(SomeString, "1") = 0 Then Retval = False
If Not InStr(SomeString, "2") = 0 Then Retval = False
If Not InStr(SomeString, "3") = 0 Then Retval = False
If Not InStr(SomeString, "4") = 0 Then Retval = False
If Not InStr(SomeString, "5") = 0 Then Retval = False
If Not InStr(SomeString, "6") = 0 Then Retval = False
If Not InStr(SomeString, "7") = 0 Then Retval = False
If Not InStr(SomeString, "8") = 0 Then Retval = False
If Not InStr(SomeString, "9") = 0 Then Retval = False
IsValidWord = Retval
End Function
Private Sub CommandButton1_Click()
SpanishLCID = 3082 'The source text is in Spanish
ListBox1.Clear
Dim WordsTotal As Long
WordsTotal = ActiveDocument.Words.Count
TextBox1.Text = Str(WordsTotal)
Dim Wordfound As Boolean
Dim NewWord As String
Dim MyData() As WordStatData
ReDim Preserve MyData(1)
NewWord = ""
For i = 1 To WordsTotal
NewWord = Trim(StrConv(Trim(ActiveDocument.Words(i)), vbLowerCase, SpanishLCID))
'Check if the word is in the list
If IsValidWord(NewWord) Then
Wordfound = False
For j = 1 To UBound(MyData)
If StrComp(MyData(j).WordText, NewWord) = 0 Then
Wordfound = True: Exit For
End If
Next j
If Wordfound Then
MyData(j).WordCount = MyData(j).WordCount + 1
Else
ReDim Preserve MyData(UBound(MyData) + 1)
MyData(UBound(MyData)).WordText = NewWord
MyData(UBound(MyData)).WordCount = 1
End If
End If
Next i
'Printing out the word list
For i = 1 To UBound(MyData)
ListBox1.AddItem (MyData(i).WordText & "=" & Str(MyData(i).WordCount))
Next i
End Sub
推荐答案
添加对 Microsoft Scripting Runtime 的引用(工具 -> 引用...).然后使用以下内容:
Add a reference to the Microsoft Scripting Runtime (Tools -> References...). Then use the following:
Private Sub CommandButton1_Click()
Const SpanishLCID = 3082
Dim dict As New Scripting.Dictionary, word As Variant, fixedWord As String
Dim key As Variant
dict.CompareMode = SpanishLCID
For Each word In ActiveDocument.Words
fixedWord = Trim(StrConv(Trim(word), vbLowerCase, SpanishLCID))
If Not dict.Exists(fixedWord) Then
dict(fixedWord) = 1
Else
dict(fixedWord) = dict(fixedWord) + 1
End If
Next
ListBox1.Clear
For Each key In dict.Keys
ListBox1.AddItem key & "=" & dict(key)
Next
End Sub
注意.Word 将每个标点符号或段落视为一个新词.建议使用不应添加到字典中的字符串指定另一个字典或集合,并在添加到字典之前使用 .Exists
测试这些字符串.
NB. Word treats each punctuation symbol or paragraph as a new word. It may be advisable to specify another Dictionary or Collection with the strings that shouldn't be added to the dictionary, and test for those strings using .Exists
before adding to the dictionary.
一个更简洁的 IsValidWord
版本,没有正则表达式:
A more concise version of IsValidWord
without regular expressions:
Function IsValidWord(s As String) As Boolean
Const validChars As String = "abcdefghijklmnopqrstuvwxyz"
Dim i As Integer, char As String * 1
For i = 1 To Len(s)
char = Mid(s, i, 1)
If InStr(1, validChars, char, vbTextCompare) = 0 Then Exit Function
Next
IsValidWord = True
End Function
并使用 正则表达式(添加对 Microsoft VBScript 正则表达式 5.5 的引用):
and using regular expressions (add a reference to Microsoft VBScript Regular Expressions 5.5):
Dim regex As RegExp
Function IsValidWord2(s As String) As Boolean
If regex Is Nothing Then
Set regex = New RegExp
regex.Pattern = "[^a-z]"
regex.IgnoreCase = True
End If
IsValidWord2 = Not regex.Test(s)
End Function
并使用带有替换的正则表达式:
and using regular expressions with replacement:
Function GetValidWord(s As String) As String
'GetValidWord("Introduction.......3") will return "Introduction"
If regex2 Is Nothing Then
Set regex2 = New RegExp
regex2.Pattern = "[^a-z]"
regex2.Global = True
regex2.IgnoreCase = True
End If
GetValidWord = regex2.Replace(s, "")
End Function
您可以按如下方式使用它:
and you would use it as follows:
For Each word In ActiveDocument.Words
fixedWord = Trim(StrConv(Trim(word), vbLowerCase, SpanishLCID))
fixedWord = GetValidWord(fixedWord)
If Not dict.Exists(fixedWord) Then
注意:您可以将语言转换和 Trim
合并到 GetValidWord
中.
NB: You might combine the language conversion and Trim
into GetValidWord
.
这篇关于VBA中的单词出现:如何加速的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!