VBA Code Examples (2)

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 2

True title case

Word has the ability to set a block of text in title case, i.e. each of the words formatted so that its first letter is capitalized, thus:

A Tale Of Two Cities but formatting styles often dictate that articles, prepositions, and conjunctions should be in lower case, thus: A Tale of Two Cities.

Word has no built-in function to perform this type of formatting, but it can be achieved with a macro. The following sets the selected text in Word's title case and then sets all the words in the first array:

vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
"If", "In", "Of", "On", "Or", "The", "To", "With")

to their lower case equivalents with acorresponding array

vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
"if", "in", "of", "on", "or", "the", "to", "with")

The list of corrections can be expanded as required by simply adding the word in its alternative forms to both lists.

If one of the listed words was the first word in the selected text, then it too would be set in lower case, so that too needs to be corrected, and similarly if there is a colon in the selected text, the word following the colon would need to be corrected. The macro forces capitalization on the first letters of all words that appear in either position.

Option Explicit

Sub TrueTitleCase()
'Graham Mayor - https://www.gmayor.com - Last updated - 18 Mar 2022
Dim rSel As Range, oRng As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long

Set oRng = Selection.Range
Set rSel = Selection.Range
'count the characters in the selected string
k = Len(rSel)
If k < 1 Then
'If none, then no string is selected
'so warn the user
MsgBox "Select the text first!", vbOKOnly, "No text selected"
Exit Sub 'and quit the macro
End If
'format the selected string as title case
vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
"If", "In", "Of", "On", "Or", "The", "To", "With")
'list their replacements in a matching array
vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
"if", "in", "of", "on", "or", "the", "to", "with")
With rSel
.Case = wdTitleWord
'omit the first word
.MoveStart unit:=wdWord, Count:=1
'list the exceptions to look for in an array
With .Find
'replace items in the first list
'with the corresponding items from the second
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Format = True
.MatchCase = True
For i = LBound(vFindText) To UBound(vFindText)
.Text = vFindText(i)
.Replacement.Text = vReplText(i)
.Execute Replace:=wdReplaceAll
Next i
End With
End With
'Optionally capitalize the first character of any word following a colon
FixColon oRng
lbl_Exit:
Set rSel = Nothing
Set oRng = Nothing
Exit Sub
End Sub

Private Sub FixColon(oRng As Range)
Const sList As String = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim rSel As Range
oRng.Select
Set rSel = Selection.Range
With rSel.Find
.Text = ":"
Do While .Execute
If rSel.InRange(oRng) = False Then Exit Do
rSel.MoveStartUntil sList
rSel.Characters(1).Case = wdUpperCase
rSel.Collapse 0
Loop
End With
oRng.Select
lbl_Exit:
Exit Sub
End Sub

Extract acronyms to a new document

A forum contributor asked if it was possible to extract acronyms to a new document. The following will extract all words in the format NATO or N.A.T.O. consisting of more than two characters to a new document. The list is then sorted and duplicate entries removed. The macro does not extract acronyms that are adopted as proper nouns e.g. Unesco.

Option Explicit

Sub ExtractAcronyms()
Dim rText As Range, oRng As Range
Dim oSourceDoc As Document
Dim oTargetDoc As Document
Dim oCol As Collection
Dim i As Long
Set oSourceDoc = ActiveDocument
Set oTargetDoc = Documents.Add
Set oCol = New Collection
oSourceDoc.Activate
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = ""
Do While .Execute(findText:="[A-Z.]{2,}", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
Set rText = Selection.Range
On Error Resume Next
oCol.Add rText.Text, rText.Text
rText.Collapse wdCollapseEnd
On Error GoTo 0
Loop
End With
End With
With oTargetDoc
For i = 1 To oCol.Count
.Range.InsertAfter oCol(i)
If i < oCol.Count Then
.Range.InsertParagraphAfter
End If
Next i
.Range.Sort ExcludeHeader:=False, _
FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
.Activate
End With
lbl_Exit:
Exit Sub
End Sub

Format part of a found text string

Word's replace function is capable of applying formatting to found strings, but only the whole of a found string. Sometimes it is desirable to format only part of the string e.g. you may search for the chemical symbol for water H2O in order to format the 2 as subscript. The replace function cannot do that. With this example the simplest solution is to copy the correctly formatted version to the clipboard and replace the find string H2O with the clipboard contents H₂O i.e. put ^c in the replace with box.

You could create a macro to do so. The following shows two techniques for selecting a digit from a found item.

Option Explicit

Sub Subscript2_in_H2O()
Dim rText As Range
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(findText:="H2O", _
MatchWildcards:=False, _
Wrap:=wdFindStop, _
Forward:=True) = True
Set rText = Selection.Range
'The found text
With rText 'Do what you want with the found text
'move the start position of the found text one character right
.MoveStart Unit:=wdCharacter, Count:=1
'move the end position of the found text one character to the left
.MoveEnd Unit:=wdCharacter, Count:=-1
'the text string is now one character long i.e. the "2"
.Font.Subscript = True
'apply subscript to the remaining text string
End With
Loop 'and look for the next match
End With
End With
lbl_Exit:
Exit Sub
End Sub

or even simpler

Option Explicit

Sub Subscript2_in_H2ORev1()
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(findText:="H2O", _
MatchWildcards:=False, _
Wrap:=wdFindStop, _
Forward:=True) = True
'Do what you want with the found text (Selection.Range)
'In this case format the second character as subscripted
Selection.Range.Characters(2).Font.Subscript = True
Loop 'and look for the next match
End With
End With
lbl_Exit:
Exit Sub
End Sub

Format part of a found text string in a list of items

Extending the above procedure, you may wish to format a number of similar items - eg chemical formulae.

The following version defines the list of items as variants. Note that the subscripted numbers are located in different parts of the text string. The macro loops through the list searching for each variant throughout the document in turn. It then uses Case statements to process the range for each variant to achieve the required results.

In the cases where there are two or digits to format, they are processed separately. You could adapt this technique to format any character in the search strings in any manner you require.

Option Explicit

Sub FormatChemicalFormulae()
Dim rText As Range
Dim vFindText(4) As Variant
'match the number in the brackets
'to the last number in the list below
Dim i As Long
vFindText(0) = "H2O"
vFindText(1) = "CO2"
vFindText(2) = "H2SO4"
vFindText(3) = "SO42-"
vFindText(4) = "[CO(NH3)6]3+"
'add more numbers as required
'increment the number 'n' in the brackets vFindText(n)
For i = 0 To UBound(vFindText)
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(findText:=vFindText(i), _
MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set rText = Selection.Range 'The found text
With rText 'Do what you want with the found text
Select Case i
Case Is = 0
'H2O
.Characters(2).Font.Subscript = True
Case Is = 1
'CO2
.Characters(3).Font.Subscript = True
Case Is = 2
'H2SO4
.Characters(2).Font.Subscript = True
.Characters(5).Font.Subscript = True
Case Is = 3
'SO42
.Characters(3).Font.Subscript = True
.Characters(4).Font.Superscript = True
.Characters(5).Font.Superscript = True
Case Is = 4
'[CO(NH3)6]3+
.Characters(3).Case = wdLowerCase
.Characters(7).Font.Subscript = True
.Characters(9).Font.Subscript = True
.Characters(11).Font.Superscript = True
.Characters(12).Font.Superscript = True
End Select
End With
Loop 'and look for the next match
End With
End With
Next i
lbl_Exit:
Exit Sub
End Sub

Add a row to a table in a protected form

The following macro when run on exit from the last formfield in the last row of the table copies the last row of the table, complete with its fields and associated macros, and pastes it at the end of the table. It then removes the on exit macro from what was previously the last row, so that there can be no false triggering of the macro if a user goes back to amend a field's content in the last column of a previous row.

The code here can be applied to multiple tables in the same form.

Option Explicit

Sub AddRow()
'Run on exit from the last form field in
'the last row of the table
Dim oTable As Table
Dim oRng As Range
Dim oNewRow As Range
Dim oCell As Range
Dim oLastCell As Range
Dim sResult As String
Dim iRow As Long
Dim iCol As Long
Dim CurRow As Long
Dim i As Long, j As Long
Dim sPassword As String
sPassword = ""
'password to protect/unprotect form
With ActiveDocument
.Unprotect Password:=sPassword
'Unprotect document
Set oTable = Selection.Tables(1)
'Establish which table the cursor is in
For j = 1 To .Tables.Count
If oTable.Range.Start = .Tables(j).Range.Start Then
'Table is j
Exit For 'Stop checking
End If
Next j
'Select the appropriate table
iCol = oTable.Columns.Count 'Record the last column number
'Set a range to the last cell0
Set oLastCell = oTable.Cell(iRow, iCol).Range
'Record the last cell field value
Select Case oLastCell.FormFields(1).Type
Case 70 'wdFieldFormTextInput
sResult = oLastCell.FormFields(1).Result
Case 71 'wdFieldFormCheckBox
sResult = oLastCell.FormFields(1).CheckBox.Value
Case 83 'wdFieldFormDropDown
sResult = oLastCell.FormFields(1).DropDown.Value
End Select
'Get the value in the last cell
Set oRng = oTable.Rows.Last.Range
'Add the last row to a range
Set oNewRow = oTable.Rows.Last.Range 'Add the last row to another range
oNewRow.Collapse wdCollapseEnd 'Collapse the second range to the end of the table
oNewRow.FormattedText = oRng
'insert the content of the last row into the new range
'thereby adding a new row with the same content as the last row
CurRow = oTable.Rows.Count 'Determine the new last row of the table
For i = 1 To iCol 'Repeat for each column
Set oCell = oTable.Cell(CurRow, i).Range 'process each cell in the row
oCell.FormFields(1).Select 'Select the first field in the cell
With Dialogs(wdDialogFormFieldOptions) 'and name it
.Name = "Tab" & j & "Col" & i & "Row" & CurRow 'eg Tab1Col1Row2
.Execute 'apply the changes
End With
Next i
'Select the formfield in the last cell of the previous row
oLastCell.FormFields(1).Select
'Remove the macro
oLastCell.FormFields(1).ExitMacro = ""
'Restore the field value according to type
Select Case oLastCell.FormFields(1).Type
Case 70
oLastCell.FormFields(1).Result = sResult
Case 71
oLastCell.FormFields(1).CheckBox.Value = sResult
Case 83
oLastCell.FormFields(1).DropDown.Value = sResult
End Select
.Protect NoReset:=True, _
Password:=sPassword, _
Type:=wdAllowOnlyFormFields
'Reprotect the form
.FormFields("Tab" & j & "Col1Row" _
& CurRow).Select 'and select the next field to be completed
End With
lbl_Exit:
Set oTable = Nothing
Set oRng = Nothing
Set oNewRow = Nothing
Set oCell = Nothing
Set oLastCell = Nothing
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

This page

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

Page 4

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.