first member of each item in a dictionary needs to be an array

I have a code that loops through a document, then stores each single word in a dictionary. Each key in the dictionary is the “word” itself and each dict. item corresponding to that key is an array which has the (start and end) ranges of that word. if the shows multiple times, we simply add the new ranges to the dict. item array, meaning that the item array has become an array of arrays where each sub array holds the ranges of word instance “n”. as illustrated in this picture.

The problem is: each first sub array in each dictionary item is separated into two arrays, one storing the start range and one storing the end range as seen in the watches window. I need just one array storing both of these values, the later sub arrays are fine.

When I get to the code of highlighting, I want to highlight the words that show “x” number of times according to some user input. While the above issue is standing, each word appears to show “x+1” times, for instance if a word found “3” times, the number of items for that word say it shows “4” times which is wrong, I can fix it by subtracting (1) but I don’t want that. and yes I can write a code that highlight words with “x” frequency using “find” method.

here is the full code

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