词VBA：递归词搜索和工作计数
Word VBA: recursive word search and work count
我正在尝试创建一个 Word 宏 VBA 来执行以下操作：
- 对于活动的 Word 文档
- 找到名字“Bob”并计算“this is new”与 Bob 相关联的次数（递归搜索和计数）
- 例如。鲍勃 = 2，马修 = 1，马克 = 0
报告-日本
PQR – 鲍勃、马克
· 一些文字
报告-SH
JKL – 鲍勃、马克
· 一些文字
GHI – 鲍勃
· 这是新的。
· 更多文字
举报-JM
MNO – 鲍勃、马克
· 一些文字
DEF – 鲍勃
· 这是新的。
· 更多文字
ABC – 马修
· 这是新的。
· 更多文字
报告 – BB
PQR – 鲍勃、马克
· 一些文字
我认为我使用此代码的尝试是不正确的。有帮助吗？
sResponse = "is new"
iCount = 0
Application.ScreenUpdating = False
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = sResponse
' Loop until Word can no longer
' find the search string and
' count each instance
Do While .Execute
iCount = iCount + 1
Selection.MoveRight
Loop
End With
MsgBox sResponse & " appears " & iCount & " times
例如：
Sub Demo()
Application.ScreenUpdating = False
Dim StrNm As String, StrOut As String, i As Long
StrOut = "Bob = 0, " & _
"Matthew = 0, " & _
"Mark = 0, "
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ]@ · This is new"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
If .Text = "" Then Exit Do
StrNm = Split(.Text, " ")(0)
If InStr(StrOut, StrNm) > 0 Then
i = Split(Split(StrOut, StrNm & " = ")(1), ", ")(0)
StrOut = Replace(StrOut, StrNm & " = " & i, StrNm & " = " & i + 1)
Else
StrOut = StrOut & StrNm & " = " & 1 & ", "
End If
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
MsgBox "Frequency Report:" & StrOut
End Sub
如果您遗漏了带有 'This is new' 的任何名称，上面的代码只会将它们添加到预定义的 StrOut 列表中。
您陈述的原始问题的一部分是您想列出所有名称，包括从不显示为带有短语“This is new”的行的名称。因此，代码必须构建 Dictionary 个名称，并在扫描所有行时跟踪每个名称及其计数。 （有关字典的详细信息，请参阅 this site。）
最终解决方案中存在一些“陷阱”，包括允许使用带有重音字符的名称（例如 José）和带有空格的名称（例如“Bob Smith”）。所以我创建了一个特殊的“trim”函数来扫描每个名称并确保字符串真的只是名称。
假设：
- 不以“报告”开头的行是具有名称的行
- 破折号后以逗号分隔的单词为姓名
- 当您找到特殊的“分隔符”时，名称列表结束
示例代码如下：
Option Explicit
Sub CountPhrase()
'--- define the dash and separator characters/strings - may be special codes
Dim dash As String
Dim separator As String
Dim phrase As String
dash = "–" 'this is not a keyboard dash
separator = "·" 'this is not a keyboard period
phrase = "This is new"
Dim nameCount As Scripting.Dictionary
Set nameCount = New Scripting.Dictionary
Dim i As Long
For i = 1 To ThisDocument.Sentences.Count
'--- locate the beginning of the names lines (that DO NOT have start with "Report")
If Not (ThisDocument.Sentences(i) Like "Report*") Then
'--- pick out the names for this report
Dim dashPosition As Long
Dim separatorPosition As Long
dashPosition = InStr(1, ThisDocument.Sentences(i), dash, vbTextCompare)
separatorPosition = InStr(1, ThisDocument.Sentences(i), separator, vbTextCompare)
Dim names() As String
names = Split(Mid$(ThisDocument.Sentences(i), _
dashPosition + 1, _
separatorPosition - dashPosition), ",")
'--- now check if the phrase exists in this sentence or not
Dim phrasePosition As Long
phrasePosition = InStr(1, ThisDocument.Sentences(i), phrase, vbTextCompare)
'--- add names to the dictionary if they don't exist, and increment
' the name count if the phrase exists in this sentence
Dim name As Variant
For Each name In names
Dim thisName As String
thisName = SpecialTrim$(name)
If Len(thisName) > 0 Then
If nameCount.Exists(thisName) Then
If phrasePosition > 0 Then
nameCount(thisName) = nameCount(thisName) + 1
End If
Else
If phrasePosition > 0 Then
nameCount.Add thisName, 1
Else
nameCount.Add thisName, 0
End If
End If
End If
Next name
End If
Next i
'--- show your work
Dim popUpMsg As String
popUpMsg = "Frequency Report:"
For Each name In nameCount.Keys
popUpMsg = popUpMsg & vbCrLf & name & _
": count = " & nameCount(name)
Next name
MsgBox popUpMsg, vbInformation + vbOKOnly
End Sub
Function SpecialTrim(ByVal inString As String) As String
'--- this function can be tricky, because you have to allow
' for characters with accents and you must allow for names
' with spaces (e.g., "Bob Smith")
'--- trim from the left until the first allowable letter
Dim keepString As String
Dim thisLetter As String
Dim i As Long
For i = 1 To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
Exit For
End If
Next i
'-- special case: if ALL of the letters are not allowed, return
' an empty string
If i = Len(inString) Then
SpecialTrim = vbNullString
Exit Function
End If
'--- now transfer allowable characters to the keeper
' we're done when we reach the first unallowable letter (or the end)
For i = i To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
keepString = keepString & thisLetter
Else
Exit For
End If
Next i
SpecialTrim = Trim$(keepString)
End Function
Function LetterIsAllowed(ByVal inString As String) As Boolean
'--- inString is expected to be a single character
' NOTE: a space " " is allowed in the middle, so the caller must
' Trim the returned string
Const LETTERS = " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"àáâãäåçèéêëìíîïðñòóôõöùúûüýÿŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝ"
Dim i As Long
For i = 1 To Len(LETTERS)
If inString = Mid$(LETTERS, i, 1) Then
LetterIsAllowed = True
Exit Function
End If
Next i
LetterIsAllowed = False
End Function
我正在尝试创建一个 Word 宏 VBA 来执行以下操作：
- 对于活动的 Word 文档
- 找到名字“Bob”并计算“this is new”与 Bob 相关联的次数（递归搜索和计数）
- 例如。鲍勃 = 2，马修 = 1，马克 = 0
报告-日本
PQR – 鲍勃、马克 · 一些文字
报告-SH
JKL – 鲍勃、马克 · 一些文字
GHI – 鲍勃 · 这是新的。 · 更多文字
举报-JM
MNO – 鲍勃、马克 · 一些文字
DEF – 鲍勃 · 这是新的。 · 更多文字
ABC – 马修 · 这是新的。 · 更多文字
报告 – BB
PQR – 鲍勃、马克 · 一些文字
我认为我使用此代码的尝试是不正确的。有帮助吗？
sResponse = "is new"
iCount = 0
Application.ScreenUpdating = False
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = sResponse
' Loop until Word can no longer
' find the search string and
' count each instance
Do While .Execute
iCount = iCount + 1
Selection.MoveRight
Loop
End With
MsgBox sResponse & " appears " & iCount & " times
例如：
Sub Demo()
Application.ScreenUpdating = False
Dim StrNm As String, StrOut As String, i As Long
StrOut = "Bob = 0, " & _
"Matthew = 0, " & _
"Mark = 0, "
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ]@ · This is new"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
If .Text = "" Then Exit Do
StrNm = Split(.Text, " ")(0)
If InStr(StrOut, StrNm) > 0 Then
i = Split(Split(StrOut, StrNm & " = ")(1), ", ")(0)
StrOut = Replace(StrOut, StrNm & " = " & i, StrNm & " = " & i + 1)
Else
StrOut = StrOut & StrNm & " = " & 1 & ", "
End If
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
MsgBox "Frequency Report:" & StrOut
End Sub
如果您遗漏了带有 'This is new' 的任何名称，上面的代码只会将它们添加到预定义的 StrOut 列表中。
您陈述的原始问题的一部分是您想列出所有名称，包括从不显示为带有短语“This is new”的行的名称。因此，代码必须构建 Dictionary 个名称，并在扫描所有行时跟踪每个名称及其计数。 （有关字典的详细信息，请参阅 this site。）
最终解决方案中存在一些“陷阱”，包括允许使用带有重音字符的名称（例如 José）和带有空格的名称（例如“Bob Smith”）。所以我创建了一个特殊的“trim”函数来扫描每个名称并确保字符串真的只是名称。
假设：
- 不以“报告”开头的行是具有名称的行
- 破折号后以逗号分隔的单词为姓名
- 当您找到特殊的“分隔符”时，名称列表结束
示例代码如下：
Option Explicit
Sub CountPhrase()
'--- define the dash and separator characters/strings - may be special codes
Dim dash As String
Dim separator As String
Dim phrase As String
dash = "–" 'this is not a keyboard dash
separator = "·" 'this is not a keyboard period
phrase = "This is new"
Dim nameCount As Scripting.Dictionary
Set nameCount = New Scripting.Dictionary
Dim i As Long
For i = 1 To ThisDocument.Sentences.Count
'--- locate the beginning of the names lines (that DO NOT have start with "Report")
If Not (ThisDocument.Sentences(i) Like "Report*") Then
'--- pick out the names for this report
Dim dashPosition As Long
Dim separatorPosition As Long
dashPosition = InStr(1, ThisDocument.Sentences(i), dash, vbTextCompare)
separatorPosition = InStr(1, ThisDocument.Sentences(i), separator, vbTextCompare)
Dim names() As String
names = Split(Mid$(ThisDocument.Sentences(i), _
dashPosition + 1, _
separatorPosition - dashPosition), ",")
'--- now check if the phrase exists in this sentence or not
Dim phrasePosition As Long
phrasePosition = InStr(1, ThisDocument.Sentences(i), phrase, vbTextCompare)
'--- add names to the dictionary if they don't exist, and increment
' the name count if the phrase exists in this sentence
Dim name As Variant
For Each name In names
Dim thisName As String
thisName = SpecialTrim$(name)
If Len(thisName) > 0 Then
If nameCount.Exists(thisName) Then
If phrasePosition > 0 Then
nameCount(thisName) = nameCount(thisName) + 1
End If
Else
If phrasePosition > 0 Then
nameCount.Add thisName, 1
Else
nameCount.Add thisName, 0
End If
End If
End If
Next name
End If
Next i
'--- show your work
Dim popUpMsg As String
popUpMsg = "Frequency Report:"
For Each name In nameCount.Keys
popUpMsg = popUpMsg & vbCrLf & name & _
": count = " & nameCount(name)
Next name
MsgBox popUpMsg, vbInformation + vbOKOnly
End Sub
Function SpecialTrim(ByVal inString As String) As String
'--- this function can be tricky, because you have to allow
' for characters with accents and you must allow for names
' with spaces (e.g., "Bob Smith")
'--- trim from the left until the first allowable letter
Dim keepString As String
Dim thisLetter As String
Dim i As Long
For i = 1 To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
Exit For
End If
Next i
'-- special case: if ALL of the letters are not allowed, return
' an empty string
If i = Len(inString) Then
SpecialTrim = vbNullString
Exit Function
End If
'--- now transfer allowable characters to the keeper
' we're done when we reach the first unallowable letter (or the end)
For i = i To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
keepString = keepString & thisLetter
Else
Exit For
End If
Next i
SpecialTrim = Trim$(keepString)
End Function
Function LetterIsAllowed(ByVal inString As String) As Boolean
'--- inString is expected to be a single character
' NOTE: a space " " is allowed in the middle, so the caller must
' Trim the returned string
Const LETTERS = " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"àáâãäåçèéêëìíîïðñòóôõöùúûüýÿŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝ"
Dim i As Long
For i = 1 To Len(LETTERS)
If inString = Mid$(LETTERS, i, 1) Then
LetterIsAllowed = True
Exit Function
End If
Next i
LetterIsAllowed = False
End Function