Макрос для форматирования таблиц в word

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

Sub m_1()
Dim response As String
Dim oTable As Table
Dim oSec As Section
Dim oFootnote As Footnote
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter
'Размер шрифта
    ActiveDocument.Range.Font.Size = 8
'Копия документа
    response = MsgBox("Есть копия данного документа?", vbCritical + vbYesNo, "Предупреждение")
        If response = vbNo Then
            Exit Sub
        End If
'Принять все Изменения
    ActiveDocument.AcceptAllRevisions
    
'Обычный режим
    ActiveWindow.View.Type = wdNormalView
'Шрифт
    ActiveDocument.Range.Font.Name = "Times New Roman"
'Одинарный междустрочный интервал
    ActiveDocument.Range.ParagraphFormat.Space1
'Во всём документе Основной текст (не Уровень 1, Уровень 2 и т.д.)
    ActiveDocument.Range.Paragraphs.OutlineLevel = wdOutlineLevelBodyText
'Удаляем в 2 этапа все разрывы разделов
    If ActiveDocument.Sections.Count > 1 Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "^b"
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
        End With
        Selection.MoveLeft
        Selection.TypeParagraph
        Do While Selection.Sections(1).Index <> ActiveDocument.Sections.Count - 1
            Application.Browser.Next
            Application.Browser.Next
            Selection.MoveLeft
            Selection.TypeParagraph
        Loop
        
        Selection.HomeKey unit:=wdStory
            
        With Selection.Find
            .Text = "^b"
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            While .Execute
                .Parent.Delete
            Wend
        End With
    End If
'Удаляем Разрывы страниц
    With ActiveDocument.Range.Find
        .Text = "^m"
        .Replacement.Text = "^p"
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
'Установка Параметров страниц
    For Each oSec In ActiveDocument.Sections
        With oSec.PageSetup
            .PaperSize = wdPaperA4
            .Orientation = wdOrientLandscape
            .Gutter = CentimetersToPoints(0)
            .TopMargin = CentimetersToPoints(0.8)
            .BottomMargin = CentimetersToPoints(0.8)
            .LeftMargin = CentimetersToPoints(0.8)
            .RightMargin = CentimetersToPoints(0.8)
            
            .FirstPageTray = wdPrinterDefaultBin
            .OtherPagesTray = wdPrinterDefaultBin
            .OddAndEvenPagesHeaderFooter = False
            .DifferentFirstPageHeaderFooter = False
            .HeaderDistance = CentimetersToPoints(0.1)
            .FooterDistance = CentimetersToPoints(0.1)
            .VerticalAlignment = wdAlignVerticalTop
        End With
    Next
'Удаляем Гиперссылки во Всём документе
    'в Основном документе
        Do While ActiveDocument.Hyperlinks.Count <> 0
            ActiveDocument.Hyperlinks(1).Delete
        Loop
    'в Сносках
        For Each oFootnote In ActiveDocument.footnotes
            Do While oFootnote.Range.Hyperlinks.Count <> 0
                oFootnote.Range.Hyperlinks(1).Delete
            Loop
        Next
'Удаляем колонтитулы и делаем нумерацию страниц "Продолжить"
    For Each oSec In ActiveDocument.Sections
        For Each oHeader In oSec.Headers
            oHeader.Range.Delete
        Next oHeader
        For Each oFooter In oSec.Footers
            oFooter.Range.Delete
            oFooter.PageNumbers.RestartNumberingAtSection = False
        Next oFooter
    Next oSec
'Не показываем скрытый текст, т.к. не удаётся от него избавиться с помощью макросов
    With ActiveWindow
        With .View
            .ShowTabs = True
            .ShowSpaces = True
            .ShowParagraphs = True
            .ShowHyphens = True
            .ShowHiddenText = False
            .ShowAll = False
        End With
    End With
'Переходим в Режим разметки
    ActiveWindow.View.Type = wdPrintView
'--------------------------------------------------------------------------------------------------------------------------
'Форматирование Таблиц
 
    For Each oTable In ActiveDocument.Tables
        oTable.Rows.WrapAroundText = False
        oTable.Rows.Alignment = wdAlignRowCenter
        oTable.AutoFitBehavior (wdAutoFitWindow)
        oTable.Rows.HeightRule = wdRowHeightAuto 'Убирает галочку "Высота строки"
    Next
ActiveDocument.Tables(2).Rows(3).Delete
ActiveDocument.Tables(3).Delete
ActiveDocument.Tables(3).Rows(3).Delete
ActiveDocument.Tables(4).Rows(3).Delete
ActiveDocument.Tables(5).Delete
ActiveDocument.Tables(5).Rows(3).Delete
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

Sub m_1()
Dim response As String
Dim oTable As Table
Dim oSec As Section
Dim oFootnote As Footnote
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter
'Размер шрифта
    ActiveDocument.Range.Font.Size = 7
'Копия документа
    response = MsgBox("Есть копия данного документа?", vbCritical + vbYesNo, "Предупреждение")
        If response = vbNo Then
            Exit Sub
        End If
'Принять все Изменения
    ActiveDocument.AcceptAllRevisions
    
'Обычный режим
    ActiveWindow.View.Type = wdNormalView
'Шрифт
    ActiveDocument.Range.Font.Name = "Times New Roman"
'Одинарный междустрочный интервал
    ActiveDocument.Range.ParagraphFormat.Space1
'Во всём документе Основной текст (не Уровень 1, Уровень 2 и т.д.)
    ActiveDocument.Range.Paragraphs.OutlineLevel = wdOutlineLevelBodyText
'Перевод Таблиц из висячего положения в положение, что они в тексте
    For Each oTable In ActiveDocument.Tables
        oTable.Rows.WrapAroundText = False
    Next
'Удаляем в 2 этапа все разрывы разделов
    If ActiveDocument.Sections.Count > 1 Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "^b"
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
        End With
        Selection.MoveLeft
        Selection.TypeParagraph
        Do While Selection.Sections(1).Index <> ActiveDocument.Sections.Count - 1
            Application.Browser.Next
            Application.Browser.Next
            Selection.MoveLeft
            Selection.TypeParagraph
        Loop
        
        Selection.HomeKey unit:=wdStory
            
        With Selection.Find
            .Text = "^b"
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            While .Execute
                .Parent.Delete
            Wend
        End With
    End If
'Удаляем Разрывы страниц
    With ActiveDocument.Range.Find
        .Text = "^m"
        .Replacement.Text = "^p"
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
'Установка Параметров страниц
    For Each oSec In ActiveDocument.Sections
        With oSec.PageSetup
            .PaperSize = wdPaperA4
            .Orientation = wdOrientLandscape
            .Gutter = CentimetersToPoints(0)
            .TopMargin = CentimetersToPoints(2)
            .BottomMargin = CentimetersToPoints(0.8)
            .LeftMargin = CentimetersToPoints(0.8)
            .RightMargin = CentimetersToPoints(0.8)
            
            .FirstPageTray = wdPrinterDefaultBin
            .OtherPagesTray = wdPrinterDefaultBin
            .OddAndEvenPagesHeaderFooter = False
            .DifferentFirstPageHeaderFooter = False
            .HeaderDistance = CentimetersToPoints(0.1)
            .FooterDistance = CentimetersToPoints(0.1)
            .VerticalAlignment = wdAlignVerticalTop
        End With
    Next
'Удаляем Гиперссылки во Всём документе
    'в Основном документе
        Do While ActiveDocument.Hyperlinks.Count <> 0
            ActiveDocument.Hyperlinks(1).Delete
        Loop
    'в Сносках
        For Each oFootnote In ActiveDocument.footnotes
            Do While oFootnote.Range.Hyperlinks.Count <> 0
                oFootnote.Range.Hyperlinks(1).Delete
            Loop
        Next
'Удаляем колонтитулы и делаем нумерацию страниц "Продолжить"
    For Each oSec In ActiveDocument.Sections
        For Each oHeader In oSec.Headers
            oHeader.Range.Delete
        Next oHeader
        For Each oFooter In oSec.Footers
            oFooter.Range.Delete
            oFooter.PageNumbers.RestartNumberingAtSection = False
        Next oFooter
    Next oSec
'Не показываем скрытый текст, т.к. не удаётся от него избавиться с помощью макросов
    With ActiveWindow
        With .View
            .ShowTabs = True
            .ShowSpaces = True
            .ShowParagraphs = True
            .ShowHyphens = True
            .ShowHiddenText = False
            .ShowAll = False
        End With
    End With
'Переходим в Режим разметки
    ActiveWindow.View.Type = wdPrintView
'--------------------------------------------------------------------------------------------------------------------------
'Форматирование Таблиц
 
'Форматирование всех таблиц
    For Each oTable In ActiveDocument.Tables
        oTable.Rows.WrapAroundText = False
        oTable.Rows.Alignment = wdAlignRowCenter
        oTable.AutoFitBehavior (wdAutoFitWindow)
        oTable.Rows.HeightRule = wdRowHeightAuto 'Убирает галочку "Высота строки"
    Next
ActiveDocument.Tables(2).Rows(3).Delete
ActiveDocument.Tables(3).Delete
ActiveDocument.Tables(3).Rows(3).Delete
ActiveDocument.Tables(4).Rows(3).Delete
ActiveDocument.Tables(5).Delete
ActiveDocument.Tables(5).Rows(3).Delete
ActiveDocument.Tables(5).AutoFitBehavior (wdAutoFitWindow)
'Анимируем текст во всех Таблицах
    For Each oTable In ActiveDocument.Tables
        oTable.Range.FormattedText.Font.Animation = wdAnimationMarchingRedAnts
        oTable.Range.Font.Bold = True
    Next
'Шрифт вне Таблиц 6 пт
    With ActiveDocument.Range.Find
        .Text = ""
        .Replacement.Text = ""
        .Font.Animation = wdAnimationNone
        .Replacement.Font.Size = 5
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
For Each oTable In ActiveDocument.Tables
    oTable.Range.FormattedText.Font.Animation = wdAnimationNone
Next
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

Sub m_1()
'Удаляем в 2 этапа скрытый текст (просто так не получается удалить)
'Анимируем скрытй текст
With ActiveDocument.Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Format = True
    .Font.Hidden = True
    .Replacement.Font.Animation = wdAnimationSparkleText
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
End With
'Удаляем Анимированный текст (он же - скрытый)
With ActiveDocument.Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Format = True
    .Font.Animation = wdAnimationSparkleText
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
End With
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14

Sub m_1() 'обработка одной таблицы
If Selection.Information(wdWithInTable) = False Then
    MsgBox "Вставьте курсор в таблицу"
End If
With Selection.Tables(1) 'уменьшение левого и право полей в ячейках - чтобы для текста было больше места
    .LeftPadding = CentimetersToPoints(0.05)
    .RightPadding = CentimetersToPoints(0.05)
End With
With Selection.Tables(1) 'ширина таблицы 9 см
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = CentimetersToPoints(9)
End With
Selection.Tables(1).Range.Font.Size = 8 'размер шрифта 8 пт
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13

Sub m_2() 'обработка всех таблиц в одном документе
Dim oTable As Table
Dim response As String
response = MsgBox("Обработать все таблицы?", vbCritical + vbYesNo) 'Чтобы случайно не запустить макрос
    If response = vbNo Then Exit Sub
For Each oTable In ActiveDocument.Tables
    oTable.LeftPadding = CentimetersToPoints(0.05)
    oTable.RightPadding = CentimetersToPoints(0.05)
    oTable.PreferredWidthType = wdPreferredWidthPoints
    oTable.PreferredWidth = CentimetersToPoints(9)
    oTable.Range.Font.Size = 8
Next
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

Sub m_1() 'обработка одной таблицы
If Selection.Information(wdWithInTable) = False Then
    MsgBox "Вставьте курсор в таблицу"
    Exit Sub
End If
With Selection.Tables(1) 'уменьшение левого и право полей в ячейках - чтобы для текста было больше места
    .LeftPadding = CentimetersToPoints(0.05)
    .RightPadding = CentimetersToPoints(0.05)
End With
With Selection.Tables(1) 'ширина таблицы 9 см
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = CentimetersToPoints(9)
End With
Selection.Tables(1).Range.Font.Size = 8 'размер шрифта 8 пт
End Sub