This is a macro that formats all the tables in a document to be a standard style called "Table Grid", and also fixes the table margins to be the full width of the page.
Sub FixTableWidth()
For Each tbl In Selection.Tables
tbl.AutoFitBehavior (wdAutoFitWindow)
tbl.AutoFitBehavior (wdAutoFitWindow)
tbl.AutoFitBehavior (wdAutoFitContent)
tbl.AutoFitBehavior (wdAutoFitContent)
tbl.AutoFitBehavior (wdAutoFitWindow)
tbl.AutoFitBehavior (wdAutoFitWindow)
Next
End Sub
Sometimes you want to just copy the text as is, without the automatic numbering changing. Here's a macro that converts all the automatic numbering into text. I based it from the comments here: http://forums.cnet.com/7723-6129_102-279799/how-to-convert-automatic-numbering-to-normal-text-in-word/
Sub Auto_Format_convert_list_numbers()
Selection.Range.ListFormat.ConvertNumbersToText
End Sub
This comes from thedoctools.com. I usually use 2 uppercase characters instead of the 3 so that's the only modification I've made.
Sub ExtractACRONYMSToNewDocument()
'=========================
'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro creates a new document,
'finds all words consisting of 2 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 2 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z]{2" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
For some reason you might find that a field is a different style to the paragraph style. This is because the field is set to "preserve formatting during updates". The follow macro goes through and unchecks this box from all fields with it to make formatting consistent.
Sub FieldsFormattingFix()
' ' Changes all fields so that they do not retain formatting.
' By Edward Chan
' '
Dim ref As Field
Dim startPos As Integer
Dim isHyperLink As Boolean
For Each ref In Selection.Range.Fields
ref.Select
If (InStr(1, ref.Code, "MERGEFORMAT")) Then
ref.Code.Text = Replace(ref.Code, " \* MERGEFORMAT", "")
ref.Update
End If
Next
End Sub
Microsoft Word has this thing where it just refuses to update everything. Headers and Footers, Table of Contents, Indexes, fields - they all require a different update mechanism. Just when you think you've updated everything, there's another thing that just doesn't get updated.
Here's a bunch of macros that will hopefully do all the updating for you.
Sub UpdateAll()
UpdateHeadersFooters
UpdateRefTables
UpdateFields
UpdateFields
UpdateFields
End Sub
Sub UpdateFields()
' Note you'll need to run this at least 3 times!
Dim myRange
Set myRange = Selection.Range
Selection.WholeStory
Selection.Fields.Update
myRange.Select
End Sub
Sub UpdateHeadersFooters()
' Doing a Print Preview updates all headers and footers. Strange but true.
ActiveDocument.ActiveWindow.View.Type = wdPrintPreview
ActiveDocument.ActiveWindow.View.Type = wdPrintView
End Sub
Sub UpdateRefTables()
' This comes from http://www.thecodecage.com/forumz/archive/index.php/t-173094.html
' This is required because Word refuses to update a Table of Tables
' using the normal update fields mechanism (although it will update a
' Table of Figures for some strange reason).
Dim TOC As TableOfContents ' Table of Contents Object
Dim TOA As TableOfAuthorities ' Table of Authorities Object
Dim TOF As TableOfFigures ' Table of Figures Object
With ActiveDocument
' The following routines update TOC, TOA or TOF contents.
' Loop through Tables Of Contents and update
For Each TOC In .TablesOfContents
TOC.Update
Next
' Loop through Tables Of Authorities and update
For Each TOA In .TablesOfAuthorities
TOA.Update
Next
' Loop through Tables Of Figures and update
For Each TOF In .TablesOfFigures
TOF.Update
Next
End With
End Sub
'
' Converts Figure X to the Figure Caption and automatic Figure fields
'
'
' Find all Figure X and replace with correct style
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Figure Caption")
With Selection.Find
.Text = "Figure X"
.Replacement.Text = "Figure SEQ Figure \* ARABIC"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Replace with fields
Selection.HomeKey Unit:=wdStory
Do While 1
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Figure Caption")
With Selection.Find
.Text = "SEQ Figure \* ARABIC"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
If Selection.Find.Execute = False Then Exit Do
' Convert to a field
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, PreserveFormatting:=False
Selection.Fields.Update
Loop
End Sub
Sub ConvertTables()
'
' Converts Table X to the Figure Caption and automatic Figure fields
'
'
' Find all Table X and replace with correct style
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Table Caption")
With Selection.Find
.Text = "Table X"
.Replacement.Text = "Table SEQ Table \* ARABIC"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Replace with fields
Selection.HomeKey Unit:=wdStory
Do While 1
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Table Caption")
With Selection.Find
.Text = "SEQ Table \* ARABIC"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
If Selection.Find.Execute = False Then Exit Do
' Convert to a field
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, PreserveFormatting:=False
Selection.Fields.Update
Loop
End Sub
This macro goes through every field in a selection, and if it is not a hyperlink, it converts it into one.
Sub FieldsToHyperLinks()
'
' Converts fields that aren't hyperlinks into Hyperlinks
' By Edward Chan (c) 2014
'
'
Dim ref As Field
Dim startPos As Integer
Dim isHyperLink As Boolean
On Error Resume Next ' Required for first list
For Each ref In Selection.Range.Fields
startPos = InStr(1, ref.Code, "\r")
isHyperLink = InStr(1, ref.Code, "\h")
If startPos > 0 And Not isHyperLink Then
Debug.Print "Original: "; ref.Code
Debug.Print "New: " & Left(ref.Code, startPos + 1) & " \h" & Right(ref.Code, Len(ref.Code) - startPos - 1)
ref.Code.Text = Left(ref.Code, startPos + 1) & " \h" & Right(ref.Code, Len(ref.Code) - startPos - 1)
ref.Update
End If
Next
End Sub
In Word 2013, the vertical scrollbar will disappear when the window is not focussed, which is a really terrible design change.
The following is an automated workaround that keeps the vertical scrollbar displayed.
It's been adapted from https://superuser.com/questions/685795/disabling-auto-hiding-of-vertical-scrollbar-in-word-2013 (with the addition of an extra line of code to force the correct view mode).
Sub Fix_Scrollbar()
'
' Fix_Scrollbar Macro
'
'
ActiveWindow.View.ReadingLayout = True
ActiveWindow.View.ReadingLayoutActualView = True ' This line is required!
Selection.EscapeKey
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdPrintView
Else
ActiveWindow.View.Type = wdPrintView
End If
End Sub
http://wordribbon.tips.net/T011671_Copying_Custom_Properties.html
Sub CopyDocProps()
Dim dp() As DocumentProperty
Dim CustomPropCount As Integer
Dim i As Integer
Dim iResponse As Integer
If Windows.Count > 2 Then
MsgBox "There are more than two windows. Please " & _
"close the others and re-run the macro.", , _
"Too many windows"
Exit Sub
End If
On Error GoTo Err_Handler
iResponse = MsgBox("Are you currently in the source document?", _
vbYesNoCancel, "Copy Custom Properties")
If iResponse = vbNo Then Application.Run MacroName:="NextWindow"
CustomPropCount = ActiveDocument.CustomDocumentProperties.Count
ReDim dp(1 To CustomPropCount)
For i = 1 To CustomPropCount
Set dp(i) = ActiveDocument.CustomDocumentProperties(i)
Next i
Application.Run MacroName:="NextWindow"
For i = 1 To CustomPropCount
If dp(i).LinkToContent = True Then
ActiveDocument.CustomDocumentProperties.Add _
Name:=dp(i).Name, _
LinkToContent:=True, _
Value:=dp(i).Value, _
Type:=dp(i).Type, _
LinkSource:=dp(i).LinkSource
Else
ActiveDocument.CustomDocumentProperties.Add _
Name:=dp(i).Name, _
LinkToContent:=False, _
Value:=dp(i).Value, _
Type:=dp(i).Type
End If
Next i
MsgBox "The properties have been copied."
Exit Sub
Err_Handler:
' if Word raises an error, then allow the user
' to update the custom document property
iResponse = MsgBox("The custom document property (" & _
dp(i).Name & ") already exists." & vbCrLf & vbCrLf & _
"Do you want to update the value?", vbYesNoCancel, _
"Copy Custom Properties")
Select Case iResponse
Case vbCancel
End
Case vbYes
ActiveDocument.CustomDocumentProperties(dp(i).Name).Value _
= dp(i).Value
Resume Next
Case vbNo
Resume Next
End Select
End Sub