Finding text between font sizes in Word VBA - vba

Question

I'm looking to find text between font sizes in Word VBA. I'm wondering if there's a better way than my code below.
It looks for the minimum font size and then iterates, incrementing by .5 until the maximum. As far as I can tell, there's no way to search for a font size range.
There's a bit of extra matching that you can ignore (it's part of a semantic-less footnote reference matching script)
Dim findResults As Scripting.Dictionary
Set findResults = CreateObject("Scripting.Dictionary")
Set contentRange = ActiveDocument.Content
' Find fonts between range
Dim min
min = 6
Dim max
max = 8
Dim currentFontSize
currentFontSize = min
Do While max >= currentFontSize
Selection.HomeKey Unit:=wdStory
Set contentRange = ActiveDocument.Content
With contentRange.Find.Font
.Size = currentFontSize
End With
With contentRange.Find.Font.Shading
.ForegroundPatternColor = wdColorAutomatic
End With
With contentRange.Find
.Text = "[0-9]{1,3}"
.MatchWildcards = True
.Wrap = wdFindStop
End With
contentRange.Find.Execute
While contentRange.Find.Found
If contentRange.Font.Position > 2 Then
Set myRange = ActiveDocument.Range(start:=contentRange.start - 10, End:=contentRange.start + Len(contentRange.Text))
findResults.Add contentRange.Text, Trim(Replace(myRange.Text, vbCr, ""))
End If
'Selection.MoveRight Unit:=wdCharacter, Count:=Len(contentRange.Text)
contentRange.Collapse wdCollapseEnd
contentRange.Find.Execute
Wend
currentFontSize = currentFontSize + 0.5
Loop

Answer 1

My approach would be to find all instances of the text, then test the font size within the loop. That way, you need only do two font size tests - .Font.Size > 5.5 and .Font.Size < 8.5. Try something based on:
Dim FindResults As Scripting.Dictionary, Rng As Range
Set FindResults = CreateObject("Scripting.Dictionary")
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[0-9]{1,3}"
.Font.Shading.ForegroundPatternColor = wdColorAutomatic
.Forward = True
.MatchWildcards = True
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found = True
If .Font.Size > 5.5 Then
If .Font.Size < 9.5 Then
If .Font.Position > 2 Then
Set Rng = .Duplicate
Rng.Start = Rng.Start - 10
FindResults.Add .Text, Trim(Replace(Rng.Text, vbCr, ""))
End If
End If
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With