Vba 所以要么你指的是不同的单词（这就是你的列表所代表的），要么就是独特的单词（一个文本中只出现一次的单词列表）。你能澄清一下你的目标是什么吗“这是一个示例测试，每个单词都是唯一的，只有一个“=12个单词，10个唯一的单词（除“is”之外），但有11个不同的单词
Vba 所以要么你指的是不同的单词（这就是你的列表所代表的），要么就是独特的单词（一个文本中只出现一次的单词列表）。你能澄清一下你的目标是什么吗“这是一个示例测试，每个单词都是唯一的，只有一个“=12个单词，10个唯一的单词（除“is”之外），但有11个不同的单词,vba,ms-word,Vba,Ms Word,所以要么你指的是不同的单词（这就是你的列表所代表的），要么就是独特的单词（一个文本中只出现一次的单词列表）。你能澄清一下你的目标是什么吗“这是一个示例测试，每个单词都是唯一的，只有一个“=12个单词，10个唯一的单词（除“is”之外），但有11个不同的单词。我已经编辑了我的初始问题，以包括使用脚本的方法。很遗憾，这并没有解决速度减慢的问题。请注意，在word vba中，标点符号被视为一个单词。段落分隔符、换行符和分页符也是如此。如果您可以使用文档的副本替换文档中的副本，则可以加快代码的速度。-另
所以要么你指的是不同的单词（这就是你的列表所代表的），要么就是独特的单词（一个文本中只出现一次的单词列表）。你能澄清一下你的目标是什么吗“这是一个示例测试，每个单词都是唯一的，只有一个“=12个单词，10个唯一的单词（除“is”之外），但有11个不同的单词。我已经编辑了我的初始问题，以包括使用脚本的方法。很遗憾，这并没有解决速度减慢的问题。请注意，在word vba中，标点符号被视为一个单词。段落分隔符、换行符和分页符也是如此。如果您可以使用文档的副本替换文档中的副本，则可以加快代码的速度。-另一种可能性是，一旦找到一个单词的所有实例，就什么也不替换。同样，在您的文档副本中！虽然这种解决方案将为您提供一个没有重复的单词列表，但不会提供唯一单词列表。独特词是指文本中只出现一次的词。示例：“这是一个示例测试，每个单词都是唯一的，只有一个除外”。您的代码将“是”列为唯一的单词，而它显然不是，它出现了两次，因此不能是唯一的。您的代码所做的是删除重复项，但这是另一回事。PEH您说得很对。我的措辞不正确，我想要一个文档中所有单词的列表，但每个单词只列出一次。我已编辑了我的初始问题，以包括使用脚本的方法。字典，不幸的是，这并没有解决速度减慢的问题。@PEH脚本字典会为您提供每个单词的计数。下一步是遍历字典并删除任何计数大于1的项（或编译第二本字典，其中项目计数仅为1。此外，请注意，我说过我的代码可能会有帮助，可能需要一些润色。@freeflow我知道^^^我想指出的是，“独特”和“独特”两个词之间有区别单词，所以这里的措词可能是错误的，或者代码不知道函数名是什么，因为它计算不同的单词。我只是想通过命名来显示代码实际上做了什么以及它假装做了什么。
Sub UniqueWordList()
Dim wList As New Collection
Dim wrd
Dim chkwrd
Dim sTemp As String
Dim k As Long
Dim cWrd As Long
Dim tWrd As Long
Dim nWrd As String
Dim Flag As Boolean
Flag = False
tWrd = ActiveDocument.Range.Words.Count
cWrd = 0
For Each wrd In ActiveDocument.Range.Words
cWrd = cWrd + 1
If cWrd Mod 100 = 0 Then
Application.StatusBar = "Updating: " & (cWrd)
End If
If Flag Then
Flag = False
GoTo nw
End If
If cWrd < tWrd Then
nWrd = ActiveDocument.Words(cWrd + 1)
nWrd = Trim(LCase(nWrd))
End If
sTemp = Trim(LCase(wrd))
If sTemp = "‘" Then
sTemp = sTemp & nWrd
Flag = True
End If
If sTemp Like "*[a-zA-Z]*" Then
k = 0
For Each chkwrd In wList
k = k + 1
If chkwrd = sTemp Then GoTo nw
If chkwrd > sTemp Then
wList.Add Item:=sTemp, Before:=k
GoTo nw
End If
Next chkwrd
wList.Add Item:=sTemp
End If
nw:
Next wrd
sTemp = "There are " & ActiveDocument.Range.Words.Count & " words "
sTemp = sTemp & "in the document, before this summary, but there "
sTemp = sTemp & "are only " & wList.Count & " unique words."
ActiveDocument.Range.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.TypeText vbCrLf & sTemp & vbCrLf
For Each chkwrd In wList
Selection.TypeText chkwrd & vbCrLf
Next chkwrd
End Sub
Sub UniqueWordListMi()
Dim wList() As String
Dim sTemp As String
Dim cWrd As Long
Dim tWrd As Long
Dim nWrd As String
Dim Flag As Boolean
Dim IsInArray As Boolean
Dim arrsize As Long
Dim rra2 As Variant
arrsize = 0
Flag = False
tWrd = ActiveDocument.Range.Words.Count
cWrd = 1
ReDim Preserve wList(0 To arrsize)
wList(arrsize) = "UNQ"
For Each wrd In ActiveDocument.Range.Words
If cWrd Mod 100 = 0 Then
Application.StatusBar = "Updating" & (cWrd)
End If
If Flag Then
Flag = False
GoTo nw
End If
If cWrd < tWrd Then
nWrd = ActiveDocument.Words(cWrd + 1)
nWrd = Trim(LCase(nWrd))
End If
sTemp = Trim(LCase(wrd))
If sTemp = "‘" Then
sTemp = sTemp & nWrd
Flag = True
End If
If sTemp Like "*[a-zA-Z]*" Then
ReDim Preserve wList(0 To arrsize)
wList(arrsize) = sTemp
arrsize = arrsize + 1
End If
nw:
cWrd = cWrd + 1
Next wrd
Set Dict = CreateObject("scripting.dictionary")
For i = 0 To UBound(wList)
If (Not Dict.Exists(CStr(wList(i)))) Then Dict.Add CStr(wList(i)), wList(i) 'Next i
Next i
rra2 = Dict.Items
sTemp = "There are " & ActiveDocument.Range.Words.Count & " words "
sTemp = sTemp & "in the document, before this summary, but there "
sTemp = sTemp & "are only " & UBound(wList) & " unique words."
ActiveDocument.Range.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.TypeText vbCrLf & sTemp & vbCrLf
For u = 0 To UBound(rra2)
Selection.TypeText vbCrLf & rra2(u) & vbCrLf
Next u
End Sub
Option Explicit
Public Function CountUniqueWords(ByRef ipRange As Word.Range) As Scripting.Dictionary
Dim myUniqueWords As Scripting.Dictionary
Set myUniqueWords = New Scripting.Dictionary
Dim myPara As Variant
For Each myPara In ipRange.Paragraphs
Dim myWord As Variant
For Each myWord In Split(myPara.Range.Text)
If myUniqueWords.Exists(myWord) Then
myUniqueWords.Item(myWord) = myUniqueWords.Item(myWord) + 1
Else
myUniqueWords.Add myWord, 1
End If
Next
Next
Set CountUniqueWords = myUniqueWords
End Function
Option Explicit
Sub UniqueWordListMi()
Dim wList As Object
Set wList = CreateObject("scripting.dictionary")
Dim sTemp As String
Dim cWrd As Long
Dim tWrd As Long
Dim nWrd As String
Dim Flag As Boolean
Dim IsInArray As Boolean
Dim arrsize As Long
Dim rra2 As Variant
arrsize = 0
Flag = False
tWrd = ActiveDocument.Range.Words.Count
cWrd = 1
Dim wrd As Variant
For Each wrd In ActiveDocument.Range.Words
If cWrd Mod 100 = 0 Then
Application.StatusBar = "Updating" & (cWrd)
End If
If Flag Then
Flag = False
GoTo nw
End If
If cWrd < tWrd Then
nWrd = ActiveDocument.Words(cWrd + 1)
nWrd = Trim(LCase(nWrd))
End If
sTemp = Trim(LCase(wrd))
If sTemp = "‘" Then
sTemp = sTemp & nWrd
Flag = True
End If
If sTemp Like "*[a-zA-Z]*" Then
If Not wList.Exists(sTemp) Then
wList.Add sTemp, 1
Else
wList.Item(sTemp) = wList.Item(sTemp) + 1
End If
cWrd = cWrd + 1
End If
nw:
Next wrd
sTemp = "There are " & (cWrd - 1) & " words "
sTemp = sTemp & "in the document, before this summary, but there "
sTemp = sTemp & "are only " & wList.Count & " distinct words."
ActiveDocument.Range.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.TypeText vbCrLf & sTemp & vbCrLf
Dim chkwrd As Variant
For Each chkwrd In wList
Selection.TypeText chkwrd & vbTab & wList.Item(chkwrd) & " times" & vbCrLf
Next chkwrd
End Sub
This is an example test where every word is unique except one.
There are 12 words in the document, before this summary, but there are only 11 distinct words.
this 1 times
is 2 times
an 1 times
example 1 times
test 1 times
where 1 times
every 1 times
word 1 times
unique 1 times
except 1 times
one 1 times
Sub UniqueWordListFast()
Dim WordDictionary As Object
Dim SourceText As Document
Dim objWord As Object
Dim sTemp As String, strWord As String, nxtWord As String
Dim count As Long
count = 0
Set WordDictionary = CreateObject("Scripting.Dictionary")
Set SourceText = Application.ActiveDocument
For Each objWord In SourceText.Range.Words
count = count + 1
strWord = Trim(objWord.Text)
If strWord = nxtWord Then GoTo nw
If strWord Like "*[a-z]*" Then WordDictionary(strWord) = strWord
If strWord Like "‘" Then
nxtWord = Trim(SourceText.Words(count + 1))
strWord = strWord & nxtWord
WordDictionary(strWord) = strWord
End If
nw:
Next
sTemp = "[DOCUMENT] " & vbTab & SourceText.Name & vbCrLf & vbCrLf & _
"There are " & SourceText.Range.Words.count & " words in the document, " & _
"before this summary, but there are only " & WordDictionary.count & " unique words."
Dim NewDocument As Document
Set NewDocument = Documents.Add
NewDocument.Range.Text = sTemp & vbCrLf & Join(WordDictionary.Keys, vbCrLf)
End Sub