VBA Code Examples (4)

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.

Option Explicit

Sub ReplaceQuotes()
Dim vFindText As Variant
Dim vReplText As Variant
Dim sFormat As Boolean
Dim sQuotes As String
Dim oRng As Range
Dim i As Long
sQuotes = MsgBox("Click 'Yes' to convert smart quotes to straight quotes." & vbCr & _
"Click 'No' to convert straight quotes to smart quotes.", _
vbYesNo, "Convert quotes")
sFormat = Options.AutoFormatAsYouTypeReplaceQuotes
If sQuotes = vbYes Then
vFindText = Array(Chr(132), Chr(147), Chr(148), ChrW(171) & ChrW(160), ChrW(160) & ChrW(187), Chr(145), Chr(146))
vReplText = Array(Chr(34), Chr(34), Chr(34), Chr(34), Chr(34), Chr(39), Chr(39))
Options.AutoFormatAsYouTypeReplaceQuotes = False
For i = LBound(vFindText) To UBound(vFindText)
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(vFindText(i))
oRng.Text = vReplText(i)
oRng.Collapse wdCollapseEnd
Loop
End With
Next i
Else
Options.AutoFormatReplaceQuotes = True
ActiveDocument.Range.AutoFormat
End If
Options.AutoFormatAsYouTypeReplaceQuotes = sFormat
lbl_Exit:
Exit Sub
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.

Option Explicit

Sub ReplaceFromTableList()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim oStory As Range
Dim rFindText As Range, rReplacement As Range
Dim i As Long
Dim sFname As String
Dim sAsk As String
sFname = "C:\Path\Changes.docx"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(Filename:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)
For i = 1 To oTable.Rows.Count
For Each oStory In oDoc.StoryRanges
Set oRng = oStory
Set rFindText = oTable.Cell(i, 1).Range
rFindText.End = rFindText.End - 1
Set rReplacement = oTable.Cell(i, 2).Range
rReplacement.End = rReplacement.End - 1
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(findText:=rFindText, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindStop) = True
oRng.Select
sAsk = MsgBox("Replace - " & vbCr & oRng & vbCr + vbCr & _
"with - " & vbCr & rReplacement, vbYesNo, _
"Replace from Table")

If sAsk = vbYes Then
oRng.FormattedText = rReplacement.FormattedText
End If
oRng.Collapse wdCollapseEnd
Loop
End With
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
Set oRng = oStory
Set rFindText = oTable.Cell(i, 1).Range
rFindText.End = rFindText.End - 1
Set rReplacement = oTable.Cell(i, 2).Range
rReplacement.End = rReplacement.End - 1
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(findText:=rFindText, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindStop) = True
oRng.Select
sAsk = MsgBox("Replace - " & vbCr & oRng & vbCr + vbCr & _
"with - " & vbCr & rReplacement, vbYesNo, _
"Replace from Table")

If sAsk = vbYes Then
oRng.FormattedText = rReplacement.FormattedText
End If
oRng.Collapse wdCollapseEnd
Loop
End With
Wend
End If
Next oStory
Next i
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdPrintView
Else
ActiveWindow.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdPrintView
Else
ActiveWindow.View.Type = wdPrintView
End If
oChanges.Close wdDoNotSaveChanges
lbl_Exit:
Set oStory = Nothing
Set oRng = Nothing
Set rFindText = Nothing
Set rReplacement = Nothing
Exit Sub
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!

Option Explicit

Sub ReplaceFromTableChoices()
Dim oChangesDoc As Document
Dim oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim oldPart As Range
Dim newPart As Range
Dim oFound As Range
Dim i As Long, j As Long, iCol As Long
Dim iAsk As Long
Dim sReplaceText As String, sNum As String
Const sFname As String = "C:\Path\Changes.docx"

'Identify the document to be processed
Set oDoc = ActiveDocument
'Identify the document containing the table of changes.
'The table must have at least 3 columns.
Set oChangesDoc = Documents.Open(sFname)
'Identify the table to be used
Set oTable = oChangesDoc.Tables(1)
'Activate the document to be processed
oDoc.Activate
'Process each row of the table in turn
For i = 1 To oTable.Rows.Count
Set oRng = oDoc.Range
'Set the search item to the content of the first cell
Set oldPart = oTable.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 oRng.Find
.MatchWholeWord = True
'Look for the search item
Do While .Execute(findText:=oldPart)
'And assign the found item to a range variable
Set oFound = oRng
oFound.Select
'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 oTable.Columns.Count
'And assign the replacement choices to a range variable in turn
Set newPart = oTable.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(oTable.Cell(i, 2).Range) <> 2 And _
Len(oTable.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(Prompt:=sReplaceText & vbCr & vbCr & _
"Enter the number of the replacement for '" _
& oldPart.Text & "'", Default:=1)
If sNum = "" Then GoTo lbl_Exit 'User has click Cancel

'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 "Input must be a number between 1 & " & oTable.Columns.Count - 1 & ". 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 > oTable.Columns.Count - 1 Then
'Tell the user
MsgBox "Input must be a number between 1 & " & oTable.Columns.Count - 1 & ". 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(oTable.Cell(i, sNum + 1).Range) = 2 Then
'Tell the user
MsgBox "You have entered a number higher than the choices available! Try again.", _
vbInformation, "Error"
'and go round again
GoTo Again
End If
End If
'Set the replacement according to the user input
Set newPart = oTable.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
Skip:
oRng.Collapse 0
Loop
End With
Next i
'Close the document containing the table
oChangesDoc.Close wdDoNotSaveChanges
lbl_Exit:
Set oChangesDoc = Nothing
Set oDoc = Nothing
Set oTable = Nothing
Set oRng = Nothing
Set oldPart = Nothing
Set newPart = Nothing
Set oFound = Nothing
Exit Sub
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.

Option Explicit

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
lbl_Exit:
Exit Sub
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
lbl_Exit:
Exit Sub
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
lbl_Exit:
Exit Sub
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
lbl_Exit:
Exit Sub
End Sub

Click the links below for more Word macros

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

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

Useful Functions

BrowseforFile
Browse for Folder
FileExists
FolderExists
CleanFileName
FileNameUnique
FolderNameUnique
CreateFolders
UpdateTemplate
ExtractDigits - from text string
FillBM
ImageToBM
IsInteger
Validate Userform TextBox

Graham Mayor

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

You appear to be using ad blocking software. While I respect your right to do so, please be aware that the minimal advertising on this site helps defray the cost of providing this facility, and I would therefore ask that you turn off the blocker while browsing this site.