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 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 'Define the document containing the table of words/phrases and their replacements sFname = "D:\My Documents\Test\changes.doc" 'Define the document to be processed Set RefDoc = ActiveDocument 'Open the document with the changes Set ChangeDoc = Documents.Open(sFname) 'Define 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      'Define the cell containing the word/phrase to be replaced      Set oFind = cTable.Cell(i, 1).Range      oFind.End = oFind.End - 1      'Define 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

Insert Autotext Entry with VBA - Word 2007/2010

Word 2007 introduced building blocks which added a whole lot of other parameters and a separate building blocks template where autotext entries could be stored. Provided the autotext entry that you wish to insert is defined in the autotext gallery (or it is included in a Word 97-2003 format template or add-in, then the above macro will work as it stands. If you want to check all the galleries, then you will need some extra code. In addition to checking the active template, add-in templates and the normal template, the following finally looks in the building blocks.dotx template.

It is to be hoped that if you are using vba to insert entries, you might have a better idea of where they are stored beforehand, but this macro should do the trick wherever they are.

Sub InsertMyBuildingBlock()
Dim strText As String
Dim oTemplate As Template
Dim oAddin As AddIn
Dim bFound As Boolean
Dim i As Long

'Define the required building block entry
strText = "Building Block Name"

'Set the found flag default to False
bFound = False
'Ignore the attached template for now if the
'document is based on the normal template
If ActiveDocument.AttachedTemplate <> NormalTemplate Then
     Set oTemplate = ActiveDocument.AttachedTemplate
     'Check each building block entry in the attached template
     For i = 1 To oTemplate.BuildingBlockEntries.Count
          'Look for the building block name
          'and if found, insert it.
          If oTemplate.BuildingBlockEntries(i).name = strText Then
               oTemplate.BuildingBlockEntries(strText).Insert _
                 Where:=Selection.Range
               'Set the found flag to true
               bFound = True
               'Clean up and stop looking
               Set oTemplate = Nothing
               Exit Sub
          End If
     Next i
End If
 

'The entry has not been found
If bFound = False Then
     For Each oAddin In AddIns
          'Check currently loaded add-ins
          If oAddin.Installed = False Then Exit For
          Set oTemplate = Templates(oAddin.Path & _
            Application.PathSeparator & oAddin.name)
          'Check each building block entry in the each add in
          For i = 1 To oTemplate.BuildingBlockEntries.Count
               If oTemplate.BuildingBlockEntries(i).name = strText Then
                    'Look for the building block name
                    'and if found, insert it.
                    oTemplate.BuildingBlockEntries(strText).Insert _
                      Where:=Selection.Range
                    'Set the found flag to true
                    bFound = True
                    'Clean up and stop looking
                    Set oTemplate = Nothing
                    Exit Sub
               End If
          Next i
     Next oAddin
End If
 

'The entry has not been found. Check the normal template
If bFound = False Then
     For i = 1 To NormalTemplate.BuildingBlockEntries.Count
          If NormalTemplate.BuildingBlockEntries(i).name = strText Then
               NormalTemplate.BuildingBlockEntries(strText).Insert _
                 Where:=Selection.Range
               'set the found flag to true
               bFound = True
               Exit Sub
          End If
     Next i
End If
 

'If the entry has still not been found
'finally check the Building Blocks.dotx template
If bFound = False Then

     Templates.LoadBuildingBlocks
     For Each oTemplate In Templates
          If oTemplate.name = "Building Blocks.dotx" Then Exit For
     Next
     For i = 1 To Templates(oTemplate.FullName).BuildingBlockEntries.Count
          If Templates(oTemplate.FullName).BuildingBlockEntries(i).name = strText Then
               Templates(oTemplate.FullName).BuildingBlockEntries(strText).Insert _
                 Where:=Selection.Range
               'set the found flag to true
               bFound = True
               'Clean up and stop looking
               Set oTemplate = Nothing
               Exit Sub
          End If
     Next i
End If

'All sources have been checked and the entry is still not found
If bFound = False Then 'so tell the user.
     MsgBox "Entry not found", vbInformation, "Building Block " _
       & Chr(145) & strText & Chr(146)
End If
End Sub

Insert Autotext Entry with VBA - Word to 2003

When you request an autotext entry, Word looks into the active template first, then in add in templates and finally in the normal template. This appears rather complex to arrange with vba. While you can insert an autotext entry using vba from the attached (active) template or from the normal template, if it is present relatively simply, provided you know its location and it is present. The problems arise when the location is not known or may not be present. The following macro first checks whether the document template is the normal template. If it is not, then the document template is checked for the entry. If it is or if the entry has not been found, the macro then checks all installed add-ins. Finally, if the normal template was not checked in the first step, it is now checked. If the entry is found in any of these locations the entry is inserted and the macro quits. If not the user is given a message to that effect.

Sub InsertMyAutotext()
Dim oAT As AutoTextEntry
Dim oTemplate As Template
Dim oAddin As AddIn
Dim strText As String
Dim bFound As Boolean

'Define the required autotext entry
strText = "AutoText Name"
'Set the found flag default to False
bFound = False
'Ignore the attached template for now if the
'document is based on the normal template
If ActiveDocument.AttachedTemplate <> NormalTemplate Then
     Set oTemplate = ActiveDocument.AttachedTemplate
     'Check each autotext entry in the attached template
     For Each oAT In oTemplate.AutoTextEntries
          'Look for the autotext name
          If oAT.name = strText Then 'if found insert it
               oTemplate.AutoTextEntries(strText).Insert _
                 Where:=Selection.Range
               'Set the found flag to true
               bFound = True
               'Clean up and stop looking
               Set oTemplate = Nothing
               Exit Sub
          End If
     Next oAT
End If
 

'Autotext entry was not found
If bFound = False Then
     For Each oAddin In AddIns
          'Check currently loaded add-ins
          If oAddin.Installed = False Then Exit For
          Set oTemplate = Templates(oAddin.Path & _
            Application.PathSeparator & oAddin.name)
          'Check each autotext entry in the current attached template
          For Each oAT In oTemplate.AutoTextEntries
               If oAT.name = strText Then 'if found insert it
                    oTemplate.AutoTextEntries(strText).Insert _
                      Where:=Selection.Range
                    'Set the found flag to true
                    bFound = True
                    'Clean up and stop looking
                    Set oTemplate = Nothing
                    Exit Sub
               End If
          Next oAT
     Next oAddin
End If

'The entry has not been found check the normal template
If bFound = False Then
     For Each oAT In NormalTemplate.AutoTextEntries
          If oAT.name = strText Then
               NormalTemplate.AutoTextEntries(strText).Insert _
                 Where:=Selection.Range
               bFound = True
               Exit For
          End If
     Next oAT
End If
 

'All sources have been checked and the entry is still not found
If bFound = False Then 'so tell the user.
     MsgBox "Entry not found", vbInformation, "Autotext " _
       & Chr(145) & strText & Chr(146)
End If
End Sub

Transpose Characters

There is no function in Word to transpose the order of two characters - a function that has been available in some word processing software since before Windows found its way onto the home computer. The following macro attached to some suitable keyboard shortcut will correct that omission. The macro works with either two selected characters or the characters either side of the cursor. The macro also takes account of the case of the transposed characters. If the first character to be transposed is upper case and the second not, then after transposition the first character will be upper case and the second lower case. Where both or neither characters are upper case, the case of the characters is retained.

Sub Transpose() Dim oRng As Range Dim sText As String Dim Msg1 As String Dim Msg2 As String Dim Msg3 As String Dim MsgTitle As String Msg1 = "You must place the cursor between " & _ "the 2 characters to be transposed!" Msg2 = "There are no characters to transpose?" Msg3 = "There is no document open!" MsgTitle = "Transpose Characters" On Error GoTo ErrorHandler If ActiveDocument.Characters.Count > 2 Then      Set oRng = Selection.Range      Select Case Len(oRng)      Case Is = 0           If oRng.Start = oRng.Paragraphs(1).Range.Start Then                MsgBox Msg1, vbCritical, MsgTitle                Exit Sub           End If           If oRng.End = oRng.Paragraphs(1).Range.End - 1 Then                MsgBox Msg1, vbCritical, MsgTitle                Exit Sub           End If           With oRng                .Start = .Start - 1                .End = .End + 1                .Select                sText = .Text           End With      Case Is = 1           MsgBox Msg1, vbCritical, MsgTitle           Exit Sub      Case Is = 2           sText = Selection.Range.Text      Case Else           MsgBox Msg1, vbCritical, MsgTitle           Exit Sub      End Select      With Selection           If .Range.Characters(1).Case = 1 _           And .Range.Characters(2).Case = 0 Then                .Text = UCase(Mid(sText, 2, 1)) & _                LCase(Mid(sText, 1, 1))           Else                .Text = Mid(sText, 2, 1) & _                Mid(sText, 1, 1)           End If           .Collapse wdCollapseEnd           .Move wdCharacter, -1      End With Else      MsgBox Msg2, vbCritical, MsgTitle End If ErrorHandler: If Err.Number = 4248 Then MsgBox Msg3, vbCritical, MsgTitle End If End Sub

Count times entered into a document

	A user in a Word newsgroup asked how to total the number of times associated with documented sound bites grouped in sections, similar to that shown in the illustration below. The macro below will count all the times in the format HH:MM:SS in the section where the cursor is located.
	Sub CountTimes() 'Totals times in the current section 'Times should be in the format HH:MM:SS Dim sNum As Long Dim oRng As Range Dim sText As String Dim sHr As Long Dim sMin As Long Dim sSec As Long sHr = 0 sMin = 0 sSec = 0 sNum = Selection.Information(wdActiveEndSectionNumber) Set oRng = ActiveDocument.Range With oRng.Find      .ClearFormatting      .Replacement.ClearFormatting      .Text = "[0-9]{2}:[0-9]{2}:[0-9]{2}"      'Look for times in the format 00:00:00      .Wrap = wdFindStop      .MatchWildcards = True      Do While .Execute = True           sText = oRng.Text           'To count the whole document, omit the next line           If oRng.Information(wdActiveEndSectionNumber) = sNum Then           'Split the found time into three separate numbers           'representing hours minutes and seconds and add to           'the previously recorded hours, minutes and seconds                sHr = sHr + Left(sText, 2)                sMin = sMin + Mid(sText, 4, 2)                sSec = sSec + Right(sText, 2)           'To count the whole document, omit the next line           End If      Loop End With If sSec > 60 Then 'Divide by 60 and add to the minutes total      sMin = sMin + Int(sSec / 60)      sSec = sSec Mod 60 'The remainder is the seconds End If If sMin > 60 Then 'Divide by 60 and add to the hours total      sHr = sHr + Int(sMin / 60)      sMin = sMin Mod 60 'The remainder is the minutes End If MsgBox sHr & " hours" & vbCr & _ format(sMin, "00") & " Minutes" & vbCr & _ format(sSec, "00") & " Seconds" End Sub

Colour a form field check box with a contrasting colour when it is checked.

	In the following illustration the checked form field check box is coloured red. This can be achieved by checking the value of the check box and formatting the check box when the value is 'True'. The code uses the function Private Function GetCurrentFF() As Word.FormField used in the Bar Chart example above to get the current field name, so that the same macro can be applied to the On Exit property of each check box field.
	Private mstrFF As String Sub EmphasiseCheckedBox() Dim oFld As FormFields Dim sCount As Long Dim bProtected As Boolean Dim sPassword As String sPassword = "" 'Insert the password (if any), used to protect the form between the quotes With GetCurrentFF 'Establish field is current      mstrFF = GetCurrentFF.name End With Set oFld = ActiveDocument.FormFields sCount = oFld(mstrFF).CheckBox.Value 'Get the Checkbox field value 'Check if the document is protected and if so unprotect it If ActiveDocument.ProtectionType <> wdNoProtection Then      bProtected = True      ActiveDocument.Unprotect Password:=sPassword End If With oFld(mstrFF).Range      If sCount = True Then           .Font.Color = wdColorRed 'Set the colour of the checked box      Else           .Font.Color = wdColorAutomatic 'Set the colour of the unchecked box      End If End With   'Re-protect the form and apply the password (if any). If bProtected = True Then      ActiveDocument.Protect _      Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=sPassword End If End Sub Private Function GetCurrentFF() As Word.FormField Dim rngFF As Word.Range Dim fldFF As Word.FormField Set rngFF = Selection.Range rngFF.Expand wdParagraph For Each fldFF In rngFF.FormFields      Set GetCurrentFF = fldFF Exit For Next End Function