Need a macro to create a separate document that lists all capitalized words

J

jojolisac

Joined
Apr 10, 2022
Messages
6
Reaction score
0
I'm looking to create a list outside of the Word document that has all capitalized words within the document, but excludes sentence and paragraph starts.

Any help appreciated! Thanks.
 
macropod

macropod

Microsoft MVP
Joined
Mar 2, 2012
Messages
580
Reaction score
50
You could use a macro like:
Code: 
Sub Demo()
Application.ScreenUpdating = False
Dim SrcDoc As Document, DestDoc As Document
Set SrcDoc = ActiveDocument: Set DestDoc = Documents.Add
With SrcDoc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[A-Z][A-Za-z]@>"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    With .Words.First
      If .Start <> .Sentences.First.Start Then
        DestDoc.Range.Characters.Last.FormattedText = .FormattedText
        DestDoc.Range.InsertAfter vbCr
      End If
    End With
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub
For PC macro installation & usage instructions, see: http://www.gmayor.com/installing_macro.htm
For Mac macro installation & usage instructions, see: https://wordmvp.com/Mac/InstallMacro.html
 
J

jojolisac

Joined
Apr 10, 2022
Messages
6
Reaction score
0
This is great! And it does work, but it's pulling in some unwanteds for me.

It's working fine excluding paragraph starts, and also sentence starts, but still picking up sentence starts before tabs.

Also is it possible to only include a unique word in the list once?

Meaning, if there are multiples of the exact same capitalized word, only including it once in the list.
 
macropod

macropod

Microsoft MVP
Joined
Mar 2, 2012
Messages
580
Reaction score
50
Try:
Code: 
Sub Demo()
Application.ScreenUpdating = False
Dim SrcDoc As Document, DestDoc As Document, StrFnd As String, StrOut As String
Set SrcDoc = ActiveDocument: Set DestDoc = Documents.Add: StrOut = " "
With SrcDoc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[A-Z][A-Za-z]@>"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    StrFnd = .Text & " "
    With .Words.First
      If .Start <> .Sentences.First.Start Then
        If InStr(StrOut, " " & StrFnd) = 0 Then StrOut = StrOut & StrFnd
      End If
    End With
    .Collapse wdCollapseEnd
  Loop
End With
DestDoc.Range.Text = Replace(Trim(StrOut), " ", vbCr)
Application.ScreenUpdating = True
End Sub
 
Top