Word 2013 - Macro to Compare Doc to List of Words, and Extract Into New Doc

[kad]

Okay, so a while back I'd been asked to find a way to pull all of the trademarked words used in a document into another document. The purpose of this is to use that list of trademarked words to write an Appendix for trademarks.

This is the macro we've been using:


Sub FindTrademarks()'
' FindTrademarks Macro
'
'
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Application.ScreenUpdating = False
Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add
With oDoc_Source
Set oRange = .Range
With oRange.Find
.Text = Chr(174)
While .Execute
oRange.MoveStart wdWord, -1
oDoc_Target.Range.InsertAfter oRange & vbCr

oRange.Collapse wdCollapseEnd
Wend
End With
End With
End Sub

And it works really well. The problem though, is that this macro assumes that we've remembered to put a trademark symbol (R) by the relevant trademarks. Which isn't always the case, we all make mistakes.

What I'd like is to be able to compare the document to an excel spreadsheet list of all the trademarked words our company uses to create the new doc with the list of words.

I have a macro that finds and replaces a list of words from an excel spreadsheet:


Sub FindReplace()'
' FindReplace Macro
'


Const strXLFile = "C:\Users\kate.dupuis\Desktop\Templates\Replacements.xls"
Dim xlApp As Object
Dim xlWbk As Object
Dim xlWsh As Object
Dim blnStart As Boolean
Dim r As Long
Dim m As Long


On Error Resume Next
' Get or start Excel
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
blnStart = True
End If


On Error GoTo ErrHandler


Application.ScreenUpdating = False
' Open workbook
Set xlWbk = xlApp.Workbooks.Open(strXLFile)
' Reference to first worksheet
Set xlWsh = xlWbk.Worksheets(1)
' Get last used row
m = xlWsh.Cells(xlWsh.Rows.Count, 1).End(-4162).Row


With ActiveDocument.Content.Find
' Initialize find/replace settings
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
' Loop through rows
For r = 1 To m
' Get text to find
.Text = xlWsh.Cells(r, 1)
' And replacement
.Replacement.Text = xlWsh.Cells(r, 2)
' Replace all
.Execute Replace:=wdReplaceAll
Next r
End With


ExitHandler:
' Clean up
On Error Resume Next
Set xlWsh = Nothing
xlWbk.Close savechanges:=False
Set xlWbk = Nothing
If blnStart Then
xlApp.Quit
End If
Set xlApp = Nothing
Application.ScreenUpdating = True
Exit Sub


ErrHandler:
' Inform user
MsgBox Err.Description, vbExclamation
' And go to cleanup section
Resume ExitHandler
End Sub

But I can't make them mush.

Thanks,

kad

[gmaxey]

I've assumed that your Excel list does not include the TM symbol at the end of the word.


Const strXLFile = "D:\Data Stores\Find and Replace List.xlsx" '"C:\Users\kate.dupuis\Desktop\Templates\Replacements.xls"
Sub ExtractFirstInstanceOfTMWordsandEnsureTMSymbolIsApplied()
Dim oXLApp As Object
Dim oXLWbk As Object
Dim oXLWsh As Object
Dim bStartXL As Boolean
Dim lngIndex As Long, lngRows As Long
Dim oCol As Collection
Dim oRng As Word.Range
Dim oDoc As Word.Document

On Error Resume Next
'Get or start Excel
Set oXLApp = GetObject(, "Excel.Application")
If oXLApp Is Nothing Then
Set oXLApp = CreateObject("Excel.Application")
If oXLApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
bStartXL = True
End If
On Error GoTo ErrHandler
Application.ScreenUpdating = False
'Open workbook
Set oXLWbk = oXLApp.Workbooks.Open(strXLFile)
'Reference to first worksheet
Set oXLWsh = oXLWbk.Worksheets(1)
'Get last used row
lngRows = oXLWsh.Cells(oXLWsh.Rows.Count, 1).End(-4162).Row
Set oCol = New Collection
For lngIndex = 1 To lngRows
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.Text = oXLWsh.Cells(lngIndex, 1)
While .Execute
If Not oRng.Characters.Last.Next = Chr(174) Then
oRng.InsertAfter Chr(174)
oRng.Characters.Last.Font.Superscript = True
Else
oRng.End = oRng.End + 1
End If
oCol.Add oRng.Text, oRng.Text
oRng.Collapse wdCollapseEnd
Wend
End With
Next lngIndex
'Record results
Set oDoc = Documents.Add
For lngIndex = 1 To oCol.Count
oDoc.Range.InsertAfter oCol(lngIndex) & vbCr
oDoc.Range.Characters.Last.Previous.Previous.Font.Superscript = True
Next lngIndex
oDoc.Range.Characters.Last.Delete
lbl_Exit:
'Clean up
On Error Resume Next
Set oXLWsh = Nothing
oXLWbk.Close savechanges:=False
Set oXLWbk = Nothing
If bStartXL Then oXLApp.Quit
Set oXLApp = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Select Case Err.Number
Case 457 'Key error. Word already in collection.
Resume Next
Case Else
'Inform user
MsgBox Err.Description, vbExclamation
Resume lbl_Exit
End Select
End Sub

[kad]

This was absolutely perfect, and the added bonus of automating inserting the TMs so thank you so much for that!!!

-kad