Turning Excel VB script into a word VB Script

[davidathomas]

All,

Some months ago, I was lucky enough to find a Very Useful Excel Macro online.

The macro parses text in Cell A1, and returns a list of all 'defined terms' in the text. By 'defined terms' I mean words, or phrases, which are capitalised.

For example, parsing the first sentence, it would return:

"Some
Very Useful Excel Macro"

Unfortunately, excel only allows so much text to be put into a cell. This won't work, with a 300 page document. So does anyone know how I might be able to translate this macro into word?

I have a word macro which does the same thing, but unfortunately it returns too many results. It returns:

Some
Very
Useful
Very Useful
Excel
Very Useful Excel

etc.



Even the excel macro is a bit too overinclusive, insofar as it always returns the first word of every sentence (Ideally it shouldn't return 'some'). But it's still more useful than the word macro.


The Excel macro:

Sub Test2()
Columns(3).Clear
MyString = Cells(1, 1)
MyString = Application.Substitute(MyString, ",", " ")
MyString = Application.Substitute(MyString, "(", " ")
MyString = Application.Substitute(MyString, ")", " ")
MyString = Application.Substitute(MyString, ".", " ")
For N = 1 To 10
MyString = Application.Substitute(MyString, " ", " ")
MyString = MyString & " xxxxx"
Next N
MyArray = Split(MyString, " ")
CapitalisedPhrase = ""
For N = 0 To UBound(MyArray)
If UCase(Left(MyArray(N), 1)) = Left(MyArray(N), 1) And Application.CountIf(Sheets("Words to ignore").Columns(1), MyArray(N)) = 0 Then
CapitalisedPhrase = CapitalisedPhrase & " " & MyArray(N)
Else
If Application.CountIf(Columns(3), Trim(CapitalisedPhrase)) = 0 Then
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) = Trim(CapitalisedPhrase)
End If
CapitalisedPhrase = ""
End If
Next N
End Sub



-------
The word macro:


Sub GetKeyWords()
Application.ScreenUpdating = False
Dim Rng1 As Range, Rng2 As Range, StrOut As String, StrExcl As String
StrOut = vbCr
StrExcl = ",A,But,He,Her,I,It,Not,Of,She,The,They,To,We,Who,You,"
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[A-Z][A-z0-9]{1,}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
Set Rng1 = .Duplicate
If InStr(StrExcl, "," & Trim(Rng1.Text) & ",") > 0 Then GoTo NextWord
Rng1.MoveStart wdWord, -1
On Error Resume Next
If Not Rng1.Characters.First.Text Like "[.?!]" Then
Set Rng2 = .Duplicate
While Rng2.Words.Last.Next.Characters.First.Text Like "[A-Z&]"
Rng2.MoveEnd wdWord, 1
Wend
End If
If InStr(StrOut, vbCr & Rng2.Text & vbCr) = 0 Then
StrOut = StrOut & Rng2.Text & vbCr
End If
NextWord:
On Error GoTo 0
.Start = Rng1.End
If Not Rng2 Is Nothing Then .Start = Rng2.End
Set Rng2 = Nothing
.Find.Execute
Loop
End With
With ActiveDocument
Set Rng1 = .Range.Characters.Last
With Rng1
.InsertAfter vbCr & Chr(12) & StrOut
.Start = .Start + 2
.Characters.First.Delete
.ConvertToTable Separator:=vbTab, Numcolumns:=1
.Tables(1).Sort Excludeheader:=False, FieldNumber:=1, _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending, CaseSensitive:=False
End With
End With
Set Rng1 = Nothing
Application.ScreenUpdating = True
End Sub

 

[Macropod]

The Word macro looks rather like one I wrote! You can probably get the results you're after with it, by changing:
If Not Rng1.Characters.First.Text Like "[.?!]" Then
to:
If Not Rng1.Characters.First.Text Like "[.?!" & vbCr & Chr(12) & "]" Then

PS: When posting code, please use the code tags. They're on the 'Go Advanced' tab.