Merging Macros

[SueBK]

I'm an avid Word macro user, but usually stick to things I can record
rather than write.
I have a four macros, all the same code with slight tweaks, that open a
excel spreadsheet, find the words in column A, replace them with th
words in column B, highlight the change, and then close the excel s/s.
found the code for the macro online and I have a reasonable handle o
how it works.

I have four separate macros so that each one can use a differen
highlight colour to draw my attention to different issues:
1 - finds and replaces, highlights yellow
2 - finds, but has no replacement values, highlights green
3 - finds an opening bracket, followed by characters, highlights blue
4 - finds legislation in column A, highlights pink.

What I'd like to do now is merge all four macros, so I can run them of
a single button. Ideally, I'd like to actually keep the four separat
(so I can also run them individually) and have a 5th macro to batch run
Sounds simple, but I can't get it to work.

The code for the individual macros is:
Sub <NAME>()
'File name with terms to check
Const strXLFile = "C:\Users\name\Documents\Editing Information\Macr
Files\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
' set highligher colour to yellow
Options.DefaultHighlightColorIndex = wdYellow


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
.Replacement.Highlight = True
.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 Su

 

[Stefan Blom]

In your "last" macro, just call the macros that you want to run (they will run
in the specified order). For example:

Sub MyFirstMacro()
'code here...
End Sub

Sub MySecondMacro()
'code here...
End Sub

Sub RunAllMyMacros()
MyFirstMacro
MySecondMacro
End Sub

--
Stefan Blom
Microsoft Word MVP




"SueBK" wrote in message
I'm an avid Word macro user, but usually stick to things I can record,
rather than write.
I have a four macros, all the same code with slight tweaks, that open an
excel spreadsheet, find the words in column A, replace them with the
words in column B, highlight the change, and then close the excel s/s. I
found the code for the macro online and I have a reasonable handle on
how it works.

I have four separate macros so that each one can use a different
highlight colour to draw my attention to different issues:
1 - finds and replaces, highlights yellow
2 - finds, but has no replacement values, highlights green
3 - finds an opening bracket, followed by characters, highlights blue
4 - finds legislation in column A, highlights pink.

What I'd like to do now is merge all four macros, so I can run them off
a single button. Ideally, I'd like to actually keep the four separate
(so I can also run them individually) and have a 5th macro to batch run.
Sounds simple, but I can't get it to work.

The code for the individual macros is:
Sub <NAME>()
'File name with terms to check
Const strXLFile = "C:\Users\name\Documents\Editing Information\Macro
Files\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
' set highligher colour to yellow
Options.DefaultHighlightColorIndex = wdYellow


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
Replacement.Highlight = True
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