字典中每个项目的第一个成员需要是一个数组

Question

我有一个循环遍历文档的代码，然后将每个单词存储在字典中。字典中的每个键都是“单词”本身和每个字典。与该键对应的项目是一个数组，其中包含该单词的（开始和结束）范围。如果显示多次，我们只需将新范围添加到字典中。 item 数组，这意味着 item 数组已成为一个数组数组，其中每个子数组保存单词实例“n”的范围。如图所示。

问题是：每个字典项中的每个第一个子数组都分为两个数组，一个存储开始范围，一个存储结束范围，如手表窗口中所示。我只需要一个数组来存储这两个值，后面的子数组就可以了。

当我到达高亮代码时，我想根据一些用户输入高亮显示“x”次数的单词。虽然上述问题仍然存在，但每个单词似乎显示“x + 1”次，例如如果一个单词找到“3”次，该单词的项目数说它显示“4”次这是错误的，我可以通过减去 (1) 来修复它，但我不希望这样。是的，我可以编写一个代码，使用“查找”方法突出显示频率为“x”的单词。

这里是完整的代码

Sub MapWordsAndHighlight()
    Dim WordsDict As Object

    'a dict. to hold words and their range values
    Set WordsDict = CreateObject("Scripting.Dictionary")

    'an object representing each word in the cgosen document
    Dim WordObject As Variant

    'a temp. arr. to hold range values while adding new ones
    Dim TmpRangeArrOfDupWords() As Variant

    'the new upper bound of the tmp arr to recive the new values
    Dim TmpArrayNewUpperBound As Long

    'string that represents each words in the chosen document
    Dim SingleWord As String

    Dim i As Long
    'loop through each word in current document
    For Each WordObject In ActiveDocument.Range.Words

        'remove the surrounding spaces and store the word string
        SingleWord = Trim(WordObject.Text)

        'skip single characters
        If Len(SingleWord) > 1 Then

            'check if the word is not stored previously in the dict
            If Not WordsDict.Exists(SingleWord) Then
                WordsDict.Add Key:=SingleWord, Item:=GetWordRangeArray(WordObject)
            Else

                'dump old range vlaues into tmp array
                TmpRangeArrOfDupWords = WordsDict(SingleWord)

                'make a new place in tmp arr for new ranges
                TmpArrayNewUpperBound = UBound(TmpRangeArrOfDupWords) + 1

                'expand the tmp array
                ReDim Preserve TmpRangeArrOfDupWords(1 To TmpArrayNewUpperBound)

                'store new ranges at the last placein tmp arr
                TmpRangeArrOfDupWords(TmpArrayNewUpperBound) = GetWordRangeArray(WordObject)
                WordsDict(SingleWord) = TmpRangeArrOfDupWords
                Erase TmpRangeArrOfDupWords
            End If
        End If
    Next
    '============================================================
    '** this part highlights words that are repeated "n" times
    'loop through dict. items array
    For Each var In WordsDict.Keys
        'replace the "2" with "n" if you want to highlight the words that are repeated "n" times
        If UBound(WordsDict.Item(var)) = 2 Then
            ThisDocument.Range(WordsDict.Item(var)(1), WordsDict.Item(var)(2)).HighlightColorIndex = wdBrightGreen
        End If
    Next
    '============================================================
End Sub

Function GetWordRangeArray(WordObject) As Variant()
'static variant array of two item
    Dim RangeValue(1 To 2)

    'store the starting range
    RangeValue(1) = WordObject.Start

    'store the end range, (-1) neglect space at the end of word
    RangeValue(2) = WordObject.End - 1

    'returned value
    GetWordRangeArray = RangeValue

    'clear the array
    Erase RangeValue
End Function

Answer 1

我稍微修改了你的代码，现在可以正常工作了。

修改了什么：

1. 检查字典中是否存在某个单词的范围数组的方法。如果没有，则从空数组开始。这种方法解决了字典中每个项目的第一个成员的问题。
2. Function GetWordRangeArray() 被废除，原生 Array() 函数用于创建范围数组，所以它变成从零开始的。
3. 计算词尾WordObject.Start + Len(SingleWord))的方法，由于词尾跟点或逗号时没有尾随空格，所以原代码将最后一个字母截去而不是尾随空格。
4. 添加了嵌套循环以突出显示特定长度的每个单词的每次出现。

Sub MapWordsAndHighlight()

    'a dict. to hold words and their range values
    Dim WordsDict As Object

    'an object representing each word in the cgosen document
    Dim WordObject As Variant

    'a temp. arr. to hold range values while adding new ones
    Dim TmpRangeArrOfDupWords As Variant

    'the new upper bound of the tmp arr to recive the new values
    Dim TmpArrayNewUpperBound As Long

    'string that represents each words in the chosen document
    Dim SingleWord As String

    Dim i As Long

    Dim CurrentWord As Variant

    Dim CurrentArr As Variant

    Set WordsDict = CreateObject("Scripting.Dictionary")

    'loop through each word in current document
    For Each WordObject In ActiveDocument.Range.Words

        'remove the surrounding spaces and store the word string
        SingleWord = Trim(WordObject.Text)

        'skip single characters
        If Len(SingleWord) > 1 Then

            'dump old range values into tmp array, empty element will be created if not exists
            TmpRangeArrOfDupWords = WordsDict(SingleWord)

            'check if the old range didn't exist
            If Not IsArray(TmpRangeArrOfDupWords) Then TmpRangeArrOfDupWords = Array()

            'make a new place in tmp arr for new ranges
            TmpArrayNewUpperBound = UBound(TmpRangeArrOfDupWords) + 1

            'expand the tmp array
            ReDim Preserve TmpRangeArrOfDupWords(TmpArrayNewUpperBound)

            'store new ranges at the last place in tmp arr
            TmpRangeArrOfDupWords(TmpArrayNewUpperBound) = Array(WordObject.Start, WordObject.Start + Len(SingleWord))
            WordsDict(SingleWord) = TmpRangeArrOfDupWords
            Erase TmpRangeArrOfDupWords
        End If
    Next

    '============================================================
    '** this part highlights words that are repeated "n" times
    'loop through dict. items array
    For Each CurrentWord In WordsDict.Keys
        'replace the "2" with "n" if you want to highlight the words that are repeated "n" times
        If UBound(WordsDict(CurrentWord)) + 1 = 2 Then
            For Each CurrentArr In WordsDict(CurrentWord)
                ThisDocument.Range(CurrentArr(0), CurrentArr(1)).HighlightColorIndex = wdBrightGreen
            Next
        End If
    Next
    '============================================================
End Sub

Answer 2

如果您希望每个字典值都是一个由 2 成员数组组成的数组，那么您需要从

开始

Array(Array(a,b))

然后您可以将其扩展到

Array(Array(a,b), Array(c,d))

而不是

Array(a,b) >> Array(a,b, Array(c,d))

这就是你当前的代码所做的。

固定：

Sub MapWordsAndHighlight()

    Dim WordObject As Variant
    Dim TmpRangeArrOfDupWords() As Variant
    Dim TmpArrayNewUpperBound As Long
    Dim SingleWord As String
    Dim i As Long, var, arr
    Dim WordsDict As Object

    Set WordsDict = CreateObject("Scripting.Dictionary")

    For Each WordObject In ActiveDocument.Range.Words

        SingleWord = Trim(WordObject.Text)


        If Len(SingleWord) > 1 Then
            If Not WordsDict.Exists(SingleWord) Then
                WordsDict.Add Key:=SingleWord, Item:=GetWordRangeArray(WordObject)
            Else
                WordsDict(SingleWord) = GetWordRangeArray(WordObject, _
                                               WordsDict(SingleWord))
            End If
        End If
    Next

    For Each var In WordsDict.Keys
        If UBound(WordsDict.Item(var)) = 2 Then
            arr = WordsDict.Item(var)
            ThisDocument.Range(arr(1)(1), arr(1)(2)).HighlightColorIndex = wdBrightGreen
        End If
    Next
    '============================================================
End Sub

Function GetWordRangeArray(WordObject, Optional arr) As Variant()

    Dim RangeValue(1 To 2), ub

    RangeValue(1) = WordObject.Start
    RangeValue(2) = WordObject.End - 1

    If IsMissing(arr) Then
        Dim rv(1 To 1)
        rv(1) = RangeValue
        GetWordRangeArray = rv
    Else
        ub = UBound(arr) + 1
        ReDim Preserve arr(1 To ub)
        arr(ub) = RangeValue
        GetWordRangeArray = arr
    End If

End Function