Microsoft Office Forums - View Single Post - Help with script - Collapse Tables as of a point till the end of doc

gmayor · 02-18-2022, 04:50 AM

Your code works OK, but to make it run on a selection of tables set a range as in Macro2 of my last post i.e. the following will format the tables after the cursor position.

Code:

Dim xTbl As Table
Dim oRng As Range
Dim i As Long
    
    Application.ScreenUpdating = False
    Set oRng = ActiveDocument.Range(Selection.Range.Start, ActiveDocument.Range.End)
    For Each xTbl In oRng.Tables
        With xTbl.Range
            .Rows.HeightRule = wdRowHeightAuto
            .Rows.Height = InchesToPoints(0)
            .Rows.AllowBreakAcrossPages = False
            .Font.Size = 9
            .Font.Name = "Calibri"
            .ParagraphFormat.Alignment = wdAlignParagraphRight
            .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
            .ParagraphFormat.SpaceBefore = 1
            .ParagraphFormat.SpaceBeforeAuto = False
            .ParagraphFormat.SpaceAfter = 1
            .ParagraphFormat.SpaceAfterAuto = False
            .ParagraphFormat.RightIndent = InchesToPoints(0.08)
            .Cells.VerticalAlignment = wdCellAlignVerticalBottom
        End With
        With xTbl.Columns(1)
            For i = 1 To .Cells.Count
                .Cells(i).Range.Font.Size = 9
                .Cells(i).Range.Font.Name = "Calibri Light"
                .Cells(i).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
                .Cells(i).Range.ParagraphFormat.LeftIndent = InchesToPoints(0.13)
                .Cells(i).Range.ParagraphFormat.RightIndent = InchesToPoints(0)
                .Cells(i).Range.ParagraphFormat.FirstLineIndent = InchesToPoints(-0.11)
                .Cells(i).Range.ParagraphFormat.SpaceBefore = 1
                .Cells(i).Range.ParagraphFormat.SpaceAfter = 1
                .Cells(i).Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom
            Next
        End With
        With xTbl.Rows(1)
            For i = 1 To .Cells.Count
                .Cells(i).Range.Font.Size = 12
            Next
        End With
    Next xTbl
    Application.ScreenUpdating = True
    Set xTbl = Nothing
    Set oRng = Nothing