Finding Words and Storing in Array

[Beginner2015]

Hi - I am trying to figure out how to search through a document to find any words that are in quotes and saving them to an array. I've managed to figure out how to use the find function and store a single result into a string variable. But I'm unsure how exactly to use a loop in order to search through the whole document and save all the words that are in quotes in an array. If it's possible to save the words to the array without the quotes, this would be even better.

Any help or guidance would be greatly appreciated. Thanks in advance!

[gmayor]

The following adds the found texts (without the quotes - Chr(34)) to a collection then a simple function converts the collection to an array


Option Explicit

Sub Macro1()
Dim Coll As New Collection
Dim oRng As Range
Dim i As Long
Dim strfind As String
Dim Arr() As Variant
strfind = """*"""
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=strfind, MatchWildcards:=True)
Coll.Add Replace(oRng.Text, Chr(34), "")
Loop
End With
Arr = toArray(Coll)
lbl_Exit:
Exit Sub
End Sub

Function toArray(ByVal Coll As Collection) As Variant
Dim Arr() As Variant
Dim i As Long
ReDim Arr(1 To Coll.Count) As Variant
For i = 1 To Coll.Count
Arr(i) = Coll(i)
Next
toArray = Arr
lbl_Exit:
Exit Function
End Function


The above will only look through the main document story range. If you have text boxes and/or header footers to search then you will need separate loops for each story range.
Test with the following



For i = LBound(Arr) To UBound(Arr)
MsgBox Arr(i)
Next i

[gmaxey]

You really don't need the collection unless you only want to put "unique" words in the array. If you want to put all words found in the main text story (or selected story) then use:


Sub MacroAll()
Dim oRng As Range
Dim i As Long
Dim strfind As String
Dim strArr() As String
i = 0
strfind = "[^0147^34]<*>[^0148^34]"
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=strfind, MatchWildcards:=True)
ReDim Preserve strArr(i)
With oRng
.Start = .Start + 1
.End = .End - 1
strArr(i) = .Text
.Collapse wdCollapseEnd
End With
i = i + 1
Loop
End With
'Output
For i = 0 To UBound(strArr)
Debug.Print strArr(i)
Next
lbl_Exit:
Exit Sub
End Sub




If you only want to add unique words (i.e., don't put the a word in each time that word is encountered) the modify Grahams code as follows:



Sub MacroUnique()
Dim Coll As New Collection
Dim oRng As Range
Dim i As Long
Dim strfind As String
Dim Arr() As Variant
strfind = "[^0147^34]<*>[^0148^34]"
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=strfind, MatchWildcards:=True)
With oRng
.Start = .Start + 1
.End = .End - 1
On Error Resume Next
Coll.Add .Text, .Text
On Error GoTo 0
.Collapse wdCollapseEnd
End With

Loop
End With
Arr = toArray(Coll)
For i = 1 To UBound(Arr)
Debug.Print Arr(i)
Next
lbl_Exit:
Exit Sub


Function toArray(ByVal Coll As Collection) As Variant
Dim Arr() As Variant
Dim i As Long
ReDim Arr(1 To Coll.Count) As Variant
For i = 1 To Coll.Count
Arr(i) = Coll(i)
Next
toArray = Arr
lbl_Exit:
Exit Function
End Function

[Beginner2015]

This is great, thanks to you both! I actually did end up needing a collection because I only wanted unique words to be captured. I'm having one other small problem. I failed to take into account that your code would capture words in quotes that are only 1 or 2 characters in length. Is there any fairly simple way to avoid capturing those short words into the array?

Thanks again for the help! Many, many thanks

[gmayor]

In the original macro, locate



Do While .Execute(FindText:=strfind, MatchWildcards:=True)
Coll.Add Replace(oRng.Text, Chr(34), "")
Loop

The found text here is oRng.Text and the macro adds this to the collection
You could add further processing here to determine the length of the text e.g to omit texts of two characters (plus the quotes) add the following lines



Do While .Execute(FindText:=strfind, MatchWildcards:=True)
If Len(oRng.Text) > 4 Then
Coll.Add Replace(oRng.Text, Chr(34), "")
End If
Loop

[gmaxey]

Graham,
Your original macro, as written, is not going to exclude repeated instances of the same word.

Beginner, make the following changes in the modified version of Graham's macro that I posted:


Do While .Execute(FindText:=strfind, MatchWildcards:=True)
With oRng
.Start = .Start + 1
.End = .End - 1
If Len(.Text) > 2 Then
On Error Resume Next
Coll.Add .Text, .Text
On Error GoTo 0
End If
.Collapse wdCollapseEnd
End With
Loop