Graham Mayor

... helping to ease the lives of Microsoft Word users.

Many people access the material from this web site daily. Most just take what they want and run. That's OK, provided they are not selling on the material as their own; however if your productivity gains from the material you have used, a donation from the money you have saved would help to ensure the continued availability of this resource. Click the appropriate button above to access PayPal.

Word macros - page 4

Replace various words or phrases in a document from a table list, with a choice of replacements

It is fairly straightforward to use VBA to search for a series of words or phrases from an array or from a document containing a table (or a list comprising each item in a separate paragraph) and then either processing the found words or replacing them with a corresponding word in the adjacent column of the same table. The following examples will do each of those things:

Replace a list of words from an array

The following example uses a pair of arrays to hold corresponding lists of words, characters or phrases separated by commas.

Items from the first list are replaced with the corresponding item from the second list

vFindText = Array(Chr(147), Chr(148), Chr(145), Chr(146))

vReplText = Array(Chr(34), Chr(34), Chr(39), Chr(39))

In a practical use of the technique, the above example as shown in the macro below, is used to replace smart quotes with straight quotes (and vice versa), however the list and macro could be modified to be used to replace or process any sequence of words or phrases.

Sub ReplaceQuotes()
Dim vFindText As Variant
Dim vReplText As Variant
Dim sFormat As Boolean
Dim sQuotes As String
Dim i As Long
'Ask the user whether to format with smart or straight quotes
sQuotes = MsgBox("Click 'Yes' to convert smart quotes to straight quotes." & vbCr & _
"Click 'No' to convert straight quotes to smart quotes.", _
vbYesNo, "Convert quotes")
'Record the current setting of the autoformat option to replace straight quotes with smart quotes
sFormat = Options.AutoFormatAsYouTypeReplaceQuotes
If sQuotes = vbYes  Then 'The user has clicked 'Yes'
'Define the lists of smart quotes and their replacements
vFindText = Array(Chr(147), Chr(148), Chr(145), Chr(146))
vReplText = Array(Chr(34), Chr(34), Chr(39), Chr(39))
'Set the autoformat option to replace straight quotes with smart quotes to off
Options.AutoFormatAsYouTypeReplaceQuotes = False
'Start from the top of the document
Selection.HomeKey wdStory
With Selection.Find
.Forward = True
.Wrap = wdFindContinue
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Format = True
.MatchCase = True
'replace each item from the first array with the corresponding item in the second array
For i = LBound(vFindText) To UBound(vFindText)
.Text = vFindText(i)
.Replacement.Text = vReplText(i)
.Execute Replace:=wdReplaceAll
Next i
End With
Else 'User clicked 'No'
'Use autoformat to replace straight quotes with smart quotes
Options.AutoFormatReplaceQuotes = True
Selection.Range.AutoFormat
End If
'Finally reset the autoformat setting to its start configuration
Options.AutoFormatAsYouTypeReplaceQuotes = sFormat
End Sub

Replace a list of words from a table

In the following example, the words and their replacements are stored in adjacent columns of a two column table stored in a document - here called "changes.doc". The name is unimportant and Word 2007/2010 users could use docx format.

The table could also have more than two columns, but only the first two columns are used.

Sub ReplaceFromTableList()
Dim ChangeDoc, RefDoc As Document
Dim cTable As Table
Dim oFind, oReplace As Range
Dim i As Long
Dim sFname As String
'Identify the document containing the table of words/phrases and their replacements
sFname = "D:\My Documents\Test\changes.doc"
'Identify the document to be processed
Set RefDoc = ActiveDocument
'Open the document with the changes
Set ChangeDoc = Documents.Open(sFname)
'Identify the table to be used
Set cTable = ChangeDoc.Tables(1)
'Activate the document to be processed
RefDoc.Activate
For i = 1 To  cTable.Rows.Count
'Identify the cell containing the word/phrase to be replaced
Set oFind = cTable.Cell(i, 1).Range
oFind.End = oFind.End - 1
'Identify the cell containing the replacement word/phrase
Set oReplace = cTable.Cell(i, 2).Range
oReplace.End = oReplace.End - 1
With Selection
'Start at the top of the document
.HomeKey wdStory
'Replace the words/phrases
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Execute findText:=oFind, _
ReplaceWith:=oReplace, _
Replace:=wdReplaceAll, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
MatchCase:=True, _
Forward:=True, _
Wrap:=wdFindContinue
End With
End With
Next i
'Close the document with the table
ChangeDoc.Close wdDoNotSaveChanges
End Sub

Replace a list of words from a table and offer a choice of replacements

The final example in this trilogy of replacements using lists was prompted by a Word forum question. The user wanted initially to highlight words and phrases in a document from a list, which was easily achieved using a variation of one of the above macros, and the he ventured the possibility of the user choosing from a number of possible replacements. How practical this is in a real life situation I cannot say, but the principles involved I felt were interesting enough to repeat them here.

In this instance the macro uses a multi-column table. The first column contains the words to be located, the subsequent columns contain the replacement choices. The columns should be filled from left to right. Not all the columns (except the first) need contain any data, but the columns must be filled from left to right with no gaps.

If only the second column has data, the found item is replaced with the content of the second column If more columns to the right of the second column have data, the choices from the second and subsequent columns are presented as numbered choices in a list.

If none of the columns, except the first, contains data, then the found word is merely highlighted.

There must be no empty cells in the first column!

Sub ReplaceFromTableChoices()
Dim ChangeDoc As Document, RefDoc As Document
Dim cTable As Table
Dim oldPart As Range, newPart As Range, oFound As Range
Dim i As Long, j As Long, iCol As Long
Dim sFname As String, sReplaceText As String, sNum As String
'Identify the document containing the table of changes.
'The table must have at least 3 columns.
sFname = "D:\My Documents\Test\changes2.doc"
'Identify the document to be processed
Set RefDoc = ActiveDocument
Set ChangeDoc = Documents.Open(sFname)
'Identify the table to be used
Set cTable = ChangeDoc.Tables(1)
'Activate the document to be processed
RefDoc.Activate
'Process each row of the table in turn
For i = 1 To cTable.Rows.Count
'Set the search item to the content of the first cell
Set oldPart = cTable.Cell(i, 1).Range
'Remove the cell end character from the range
oldPart.End = oldPart.End - 1
'Start from the beginning of the document
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
'Look for the search item
Do While .Execute(findText:=oldPart)
'And assign the found item to a range variable
Set oFound = Selection.Range
'Set the start number of a counter
iCol = 1
'Set a temporary replacement text string to zero length
sReplaceText = ""
'Look into the remaining columns for replacement choices
For j = 2 To cTable.Columns.Count
'And assign the replacement choices to a range variable in turn
Set newPart = cTable.Cell(i, j).Range
'Remove the cell end character from the range
newPart.End = newPart.End - 1
'If the current cell has no content, ignore the remainder
If Len(newPart) = 0 Then Exit For
'Add the range content to the temporary replacement text string
sReplaceText = sReplaceText & iCol & ". " & _
newPart.Text & vbCr
'Increment the counter
iCol = iCol + 1
Next j
'If there is a replacement available
If Len(sReplaceText) <> 0 Then
'If there is only one such replacement
If Len(cTable.Cell(i, 2).Range) <> 2 And _
Len(cTable.Cell(i, 3).Range) = 2 Then
'Set the number of that replacement to 1
sNum = "1"
Else
Again: 'Add a label to mark the start of the user input
'If there is more than one choice,
'ask the user to pick the preferred replacement
sNum = InputBox(sReplaceText & vbCr & vbCr & _
"Enter the number of the replacement for '" _
& oldPart.Text & "'")
If sNum = "" Then Exit Sub
'The user has cancelled
'Error trap inappropriate user choices
'Check if the user has entered something other than a number
If IsNumeric(sNum) = False Then
'Tell the user
MsgBox "Invalid entry! Try again.", _
vbInformation, "Error"
'and go round again
GoTo Again
End If
'Check if the user has entered a number
'higher than the number of columns in the table
If sNum > cTable.Columns.Count Then
'Tell the user
MsgBox "Invalid entry! Try again.", _
vbInformation, "Error"
'and go round again
GoTo Again
End If
'Check if a user has picked a valid number
'higher than the available choices
If Len(cTable.Cell(i, sNum + 1).Range) = 2 Then
'Tell the user
MsgBox "Invalid entry! Try again.", _
vbInformation, "Error"
'and go round again
GoTo Again
End If
End If
'Set the replacement according to the user input
Set newPart = cTable.Cell(i, sNum + 1).Range
newPart.End = newPart.End - 1
oFound.Text = newPart.Text
Else
'There are no replacements so highlight the found item
oFound.HighlightColorIndex = wdYellow
End If
Loop
End With
End With
Next i
'Close the document containing the table
ChangeDoc.Close wdDoNotSaveChanges
End Sub

Add tabs to centre of text area and right margin

The following macro sets a centre aligned tab, centred between the current margins, and a right aligned tab at the right margin.

Sub AddTabs()
Dim iLeft As Long
Dim iRight As Long
Dim iCentre As Long
Dim iWidth As Long
With Selection
iLeft = .Sections(1).PageSetup.LeftMargin
iRight = .Sections(1).PageSetup.RightMargin
iWidth = .Sections(1).PageSetup.PageWidth
iCentre = (iWidth - iLeft - iRight) / 2
.ParagraphFormat.TabStops.Add Position:=iCentre, _
Alignment:=wdAlignTabCenter, _
Leader:=wdTabLeaderSpaces
.ParagraphFormat.TabStops.Add Position:=iWidth - (iRight + iLeft), _
Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderSpaces
End With
End Sub

 

Extract e-mail addresses from a document to a list

The following macro will extract all the e-mail addresses from a document to a new document. The macro works on the principle that autocorrect is capable of converting e-mail addresses and web links to hyperlinks. The macro then examines those hyperlinks and extracts any that contain e-mail addresses to a new document. the original document is unaffected.

Sub ExtractEMailAddresses()
Dim oSource As Document, oTarget As Document
Dim strPath As String
Dim oHLink As Hyperlink
Dim oPara As Paragraph
'Ensure there is a document to process
If Documents.Count = 0 Then
MsgBox "Open the document
with the e-mail addresses first!", _
vbCritical, _
"Extract e-mail addresses"
Exit Sub
End If
Set oSource = ActiveDocument
oSource.Save
'Store the document name and path
strPath = oSource.FullName
'Create a new document to receive the e-mail addresses
Set oTarget = Documents.Add
'Autoformat the original document to set hyperlinks
With Options
.AutoFormatReplaceHyperlinks = True
oSource.Range.AutoFormat
End With
'Ascertain which hyperlinks are to e-mail addresses
For Each oHLink In oSource.Range.Hyperlinks
If InStr(1, oHLink.Address, "mailto:") > 0 Then
'and copy them to the target document, each to a new line
With oTarget.Range
.InsertAfter oHLink.Address
.InsertAfter vbCr
End With
End If
Next oHLink
'Remove the unwanted text from the hyperlink address
oTarget.Range = Replace(oTarget.Range, "mailto:", "")
'Sort the list alphabetically
oTarget.Range.SortAscending
'Remove any blank lines
For Each oPara In oTarget.Range.Paragraphs
If Len(oPara.Range) = 1 Then oPara.Range.Delete
Next oPara
'Format the paragraphs to remove unwanted space
oTarget.Range.ParagraphFormat.SpaceAfter = 0
oTarget.Range.ParagraphFormat.SpaceBefore = 0
'Close the original document without saving to preserve the original format
oSource.Close wdDoNotSaveChanges
'Ask whether the user wants to re-open the source document
If MsgBox("Re-open the source document?", _
vbYesNo, _
"Extract e-mail addresses") = vbYes Then
Documents.Open FileName:=strPath
End If
End Sub

Fix scrambled view of some open type fonts in Word 2010

It has been observed that occasionally some open type fonts display incorrectly in Word 2010, as in the following illustration, or the display becomes completely scrambled with the words all stacked together. It has also been observed that switching to an alternative printer will fix the issue. The following macro does just that, using the One Note driver that comes with all versions of Office 2010, then restores the original printer driver.

Sub FixDisplay()
Dim sPrinter As String
sPrinter = ActivePrinter
ActivePrinter = "Send To OneNote 2010"
ActivePrinter = sPrinter
End Sub

 

Word 2010 Print Preview

2010, the print preview was changed to part of the print dialog on the File Tab of the ribbon. The familiar print preview from earlier versions can be added to the QAT (Quick Access Toolbar) with Print Preview Edit Mode from the All Commands group of the QAT editor. The following macro intercepts that function and sets the zoom level from the default of full page to 100%. Change the 100 to reflect any personally preferred zoom level.

Sub PrintPreviewEditMode()
ActiveDocument.PrintPreview
ActiveWindow.View.Zoom = 100
End Sub

 

Click the links below for more Word macros

 

 

Macros list page 4

Page 1

  • Insert Field formatting switch
  • Number documents
  • Paste unformatted text
  • Copy footnotes c/w formatting to a new document
  • Send the current document from Word by e-mail as an attachment, with the header details pre-completed, e.g. for the return of a completed form document.
  • Toggle the SQL security entry in the registry through vba

Page 2

  • True title case
  • Extract acronyms to a new document
  • Format part of a found text string
  • Format part of a found text string in a list of items
  • Add a row to a table in a protected form
  • An alternative method of adding a row to a protected table

Page 3

  • Create a bar chart based on the content of a dropdown form field
  • Repeat a block of formatted text and form fields based upon the content of another form field
  • Colour a form field check box with a contrasting colour when it is checked.
  • Count times entered into a document
  • Transpose Characters
  • Insert Autotext Entry with VBA
  • Insert Building Blocks with VBA

This page

  • Replace a list of words from an array
  • Replace a list of words from a table
  • Replace a list of words from a table and offer a choice of replacements
  • Add tabs to centre of text area and right margin
  • Extract e-mail addresses from a document to a list
  • Fix scrambled view of some open type fonts in Word 2010
  • Word 2010 Print Preview