Clean Up and Assign Template

Sub cleanup()
'
' cleanup Macro
'
'With ActiveDocument.Styles(wdStyleNormal).Font
       
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.7)
        .BottomMargin = InchesToPoints(0.7)
        .LeftMargin = InchesToPoints(1)
        .RightMargin = InchesToPoints(1)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.4)
        .FooterDistance = InchesToPoints(0.4)
        .PageWidth = InchesToPoints(8.5)
        .PageHeight = InchesToPoints(11)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
    End With
    With ActiveDocument
        .UpdateStylesOnOpen = True
        .AttachedTemplate = _
            "\\pathtotemplate\template.dotx"
        .XMLSchemaReferences.AutomaticValidation = True
        .XMLSchemaReferences.AllowSaveAsXMLWithoutValidation = False
    End With
 
End Sub

Document Clean Up

Here’s a general bunch of stuff to clean up a document inherited from someone.

Sub docfix()
'
' docfix Macro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " ^t^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = " ^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "^l"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "  "
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "^p^t"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Delete Unused Styles

I don’t recall where I found this on the interwebs. It seems to work well. If anyone finds the original source, please comment and I’ll give the credit where credit is due!

Sub DeleteUnusedStyles()
    Dim oStyle As Style
   
    On Error GoTo ErrorHandler
   
    Application.ScreenUpdating = False ' try to speed it up
 
    For Each oStyle In ActiveDocument.Styles
        'Only check out non-built-in styles
        If oStyle.BuiltIn = False Then
            With ActiveDocument.Content.Find
                .ClearFormatting
                .Style = oStyle.NameLocal
                .Execute FindText:="", Format:=True
                If .Found = False Then oStyle.Delete
            End With
        End If
    Next oStyle
   
ErrorHandler:
    Application.ScreenUpdating = False
   
End Sub

Table Cleanup

This is a moderately generic macro to clean up tables.

Sub tfixtest()
'
' tfixtest Macro
'
 
On Error GoTo ErrorHandler
    Selection.Tables(1).Select
    Selection.Rows.HeightRule = wdRowHeightAuto
    Selection.Rows.AllowBreakAcrossPages = False
       
    ' Selection.SelectCell
    Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
   
    With Selection.ParagraphFormat
        ' .RightIndent = InchesToPoints(0)
        ' .LeftIndent = InchesToPoints(0)
       
        .SpaceBefore = 1
        .SpaceBeforeAuto = False
        .SpaceAfter = 1
        .SpaceAfterAuto = False
        .CharacterUnitRightIndent = 0
               
        
    End With
   
    
    Selection.Cells.VerticalAlignment = wdCellAlignVerticalTop
    Selection.Tables(1).AutoFitBehavior (wdAutoFitWindow)
    Selection.Tables(1).AutoFitBehavior (wdAutoFitWindow)
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
   
    
    
    With Selection.Tables(1)
        .TopPadding = InchesToPoints(0.04)
        .BottomPadding = InchesToPoints(0.04)
        .LeftPadding = InchesToPoints(0.06)
        .RightPadding = InchesToPoints(0.06)
        .Spacing = 0
        .AllowPageBreaks = True
        .AllowAutoFit = True
    End With
   

    ' Selection.Style = ActiveDocument.Styles("Table Text Left (Alt-T)")
       
    
ErrorHandler:
 
      
End Sub

Below is some stuff that I was messing with but isn’t fully sorted out yet.

Sub tablefun()
 
Dim oTable As Table
Dim oCell As Variant
 
oTable.Select
 
 
For Each oCell In oTable.Range.Cells
    oCell.Width = InchesToPoints(1)
    oCell.Shading.BackgroundPatternColorIndex = wdBlue
    oCell.Range.Font.Name = "Arial"
    oCell.Range.Font.Size = 20
    oCell.Text = "ack"
Next oCell
 
 
End Sub
 
Sub FixAllTables()
     Dim tbl As Table
    
     For Each tbl In ActiveDocument.Tables
    
         Selection.Tables(1).Select
        
         
'         For Each oCell In oTable.Range.Cells
'  oCell.Width = InchesToPoints(1)
'  oCell.Shading.BackgroundPatternColorIndex = wdBlue
'  oCell.Range.Font.Name = "Arial"
'  oCell.Range.Font.Size = 20
' Next oCell
 
         Selection.Tables(1).Select
        
         With tbl.Cells(1)
        
      '   With Selection.Cells(1)
            .VerticalAlignment = wdCellAlignVerticalTop
            .TopPadding = InchesToPoints(0.06)
            .BottomPadding = InchesToPoints(0.06)
            .LeftPadding = InchesToPoints(0.04)
            .RightPadding = InchesToPoints(0.04)
            .WordWrap = False
            .FitText = False
         End With
        
         Selection.Tables(1).AutoFitBehavior (wdAutoFitWindow)
       
         Selection.Rows.HeightRule = wdRowHeightAuto
         Selection.Rows.Height = InchesToPoints(0)
         Selection.Rows.AllowBreakAcrossPages = False
                    
         Next
End Sub