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.
Sub TrueTitleCase()
Dim sText As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long
Dim m As Long
Set sText = Selection.Range
'count the characters in the selected string
k = Len(sText)
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
sText.Case = wdTitleWord
'list the exceptions to look for in an array
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 sText
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
'Reduce the range of the selected text
'to encompass only the first character
.MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
'format that character as upper case
.Case = wdUpperCase
'restore the selected text to its original length
.MoveEnd Unit:=wdCharacter, Count:=k
'and check to see if the string contains a colon
If InStr(1, sText, ":") > 0 Then
'If it does note the position of the character
'after the first colon
m = InStr(1, sText, ":") + 1
'and set that as the new start of the selected text
.MoveStart wdCharacter, m
'set the end of the selected text to include
'one extra character
.MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
'format that character as upper case
.Case = wdUpperCase
End If
End With
End Sub
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.
Sub ExtractAcronyms()
Dim rText As Range
Dim SDoc As Document
Dim TDoc As Document
Set SDoc = ActiveDocument
Set TDoc = Documents.Add
SDoc.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
TDoc.Range.InsertAfter rText & vbCr
rText.Collapse wdCollapseEnd
Loop
End With
End With
With TDoc
.Range.Sort ExcludeHeader:=False, _
FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
.Paragraphs(1).Range.Delete
.Activate
End With
End Sub
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 H2O i.e. put ^c in the replace with box.
OR
You could create a macro to do so. The following shows two techniques for selecting a digit from a found item.
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
End Sub
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
End Sub
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.
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
End Sub
In a Word forum question, a user wanted to automatically provide the function to add a row to a table in a protected form and to fill the new row with form fields to match those in the previous row, but with new field bookmark names and a calculation in the final cell to add the other fields in the row. The user had done most of the work, which I have borrowed for this example, but was having problems with the calculation.
The modified solution works in a table with seven columns. The content of the fields in the first six columns is added in the final column.
Sub addrow()
'Works with a seven column table
Dim oTable As Table
Dim Response As String
Dim CurRow As Long
Dim i As Long
Dim fCount As Long
Dim sPassword as String
Set oTable = ActiveDocument.Tables(1)
sPassword = ""
'Define the password used to protect the form (if any)
Response = MsgBox("Add new row?", vbQuestion + vbYesNo)
If Response = vbYes Then
ActiveDocument.Unprotect Password:="sPassword"
'Unprotect document
Selection.InsertRowsBelow 1
'Add a row to the bottom of the table
Selection.Collapse (wdCollapseStart)
'Put the cursor in the first cell of the new row
CurRow = Selection.Information(wdStartOfRangeRowNumber)
'Read the number of the new row
For i = 1 To oTable.Columns.Count
oTable.Cell(CurRow, i).Select
'Select the next cell for processing
Selection.FormFields.Add Range:=Selection.Range, _
Type:=wdFieldFormTextInput
'And add a form field
fCount = ActiveDocument.Range.FormFields.Count
With ActiveDocument.FormFields(fCount)
.Name = "col" & i & "row" & CurRow
'Add a unique bookmark name
.Enabled = True
'Enable the field for user entry
.CalculateOnExit = True
'set the calculate on exit check box
If i = 6 Then .ExitMacro = "addrow"
'add this macro to the cell in column 6
If i = 7 Then
'add a calculation to add the field results in cols 1 to 6
.Enabled = False
.TextInput.EditType Type:=wdCalculationText, _
Default:="=Col1Row" & CurRow _
& " + Col2Row" & CurRow _
& " + Col3Row" & CurRow _
& " + Col4Row" & CurRow _
& " + Col5Row" & CurRow _
& " + Col6Row" & CurRow, _
Format:=""
End If
End With
Next i
With ActiveDocument
.Protect NoReset:=True, Password:="sPassword", _
Type:=wdAllowOnlyFormFields 'Reprotect the form
.Range.FormFields("col1row" & CurRow).Select
'Select the first field in the new row
End With
End If
End Sub
The previous method created the new row in the table and added the fields to the cells. The following takes an alternative approach and 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 macro makes use of the wdDialogFormFieldOptions dialog, which has the following arguments: Entry, Exit, Name, Enable, TextType, TextWidth, TextDefault, TextFormat, CheckSize, CheckWidth, CheckDefault, Type, OwnHelp, HelpText, OwnStat, StatText, Calculate, to modify the field properties.
As executing this dialog box clears the user entered result of the field, if that content is later required, as seems probable, it is necessary to store the content and replace it after executing the dialog changes.
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
Dim sPassword as String
sPassword = ""
'password to protect/unprotect form
With ActiveDocument
.Unprotect Password:=sPassword
'Unprotect document
Set oTable = .Tables(1)
'Select the appropriate table
iCol = oTable.Columns.Count 'Record the last column number
Set oLastCell = oTable.Cell(iRow, iCol).Range 'Record the last cell
sResult = oLastCell.FormFields(1).Result '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 = "Col" & i & "Row" & CurRow 'eg Col1Row2
.Execute 'apply the changes
End With
Next i
'Select the formfield in the last cell of the previous row
oLastCell.FormFields(1).Select
With Dialogs(wdDialogFormFieldOptions)
.Exit = "" 'and remove the exit macro
.Execute 'apply the changes
'but note that this clears the value from the cell
End With
oLastCell.FormFields(1).Result = sResult 'so restore the result of the cell
.Protect NoReset:=True, _
Password:=sPassword, _
Type:=wdAllowOnlyFormFields
'Reprotect the form
.FormFields("Col1Row" _
& CurRow).Select 'and select the next field to be completed
End With
End Sub