Пересчет данных в таблице по примеру.

@vkopitsa · Регистрация: 11.03.2010

Студворк — интернет-сервис помощи студентам

Доброе время суток! Помогите пожалуйста .

Возможно ли как-то сделать чтобы в таблице пересчитывались данные, таблицы очень большие бывают и вручную это очень долго делать, пытался найти, но ненашол. Структура таблиц одинаковая. Описные и пример в архиве.

Зарание спасибо!!!

@Busine2009 · 14.03.2010, 21:42

vkopitsa,
тебя не пугает, что округление всегда в меньшую сторону?

Добавлено через 49 минут
В 1-ый Массив может быть добавить цифры 36 и 38?

@vkopitsa · 15.03.2010, 01:00 **[ТС]**

Наоборот, то что нужно.

Спасибо большое.

@vkopitsa · 15.03.2010, 01:13 **[ТС]**

Ище есть такие ячейки, как быть с ними.

@Busine2009 · 15.03.2010, 07:23

vkopitsa,
доработанный вариант. В коде есть пояснения, что изменено:

Visual Basic
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
Option Base 1
Dim oCell As Cell
Dim MyArray_1(19) As String
Dim MyArray_2(19) As String
Dim MyArray_3(20) As String
Dim vData_1 As Long
Dim vData_2 As Long
Sub m_1()
On Error Resume Next
'Заполняем массивы цифрами
    MyArray_1(1) = 2
    MyArray_1(2) = 4
    MyArray_1(3) = 6
    MyArray_1(4) = 8
    MyArray_1(5) = 10
    MyArray_1(6) = 12
    MyArray_1(7) = 14
    MyArray_1(8) = 16
    MyArray_1(9) = 18
    MyArray_1(10) = 20
    MyArray_1(11) = 22
    MyArray_1(12) = 24
    MyArray_1(13) = 26
    MyArray_1(14) = 28
    MyArray_1(15) = 30
    MyArray_1(16) = 32
    MyArray_1(17) = 34
    MyArray_1(18) = 36 'Добавлены два числа в Массив для обработки цифр 36 и 38
    MyArray_1(19) = 38
        MyArray_2(1) = 5
        MyArray_2(2) = 10
        MyArray_2(3) = 15
        MyArray_2(4) = 20
        MyArray_2(5) = 25
        MyArray_2(6) = 30
        MyArray_2(7) = 35
        MyArray_2(8) = 40
        MyArray_2(9) = 45
        MyArray_2(10) = 50
        MyArray_2(11) = 55
        MyArray_2(12) = 60
        MyArray_2(13) = 65
        MyArray_2(14) = 70
        MyArray_2(15) = 75
        MyArray_2(16) = 80
        MyArray_2(17) = 85
        MyArray_2(18) = 90
        MyArray_2(19) = 95
    MyArray_3(1) = 100
    MyArray_3(2) = 110
    MyArray_3(3) = 120
    MyArray_3(4) = 130
    MyArray_3(5) = 140
    MyArray_3(6) = 150
    MyArray_3(7) = 160
    MyArray_3(8) = 170
    MyArray_3(9) = 180
    MyArray_3(10) = 190
    MyArray_3(11) = 200
    MyArray_3(12) = 210
    MyArray_3(13) = 220
    MyArray_3(14) = 230
    MyArray_3(15) = 240
    MyArray_3(16) = 250
    MyArray_3(17) = 260
    MyArray_3(18) = 270
    MyArray_3(19) = 280
    MyArray_3(20) = 290
'Предупреждаем, что курсор нужно вставить в Таблицу
    If Selection.Cells.Count = 0 Then
        MsgBox "Вставьте курсор в Таблицу, в которой надо изменить цифры!", vbCritical + vbOKOnly, "Предупреждение"
        Exit Sub
    End If
    On Error GoTo 0
'Обрабатываем ячейки, содержащие "дефис"
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With ActiveDocument.Range.Find
        .Text = "-"
        .Replacement.Text = ""
        .Replacement.Font.Animation = wdAnimationMarchingBlackAnts
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
'Отделяем первую строку от Таблицы. Иначе не получится работать с конкретным столбцом, т.к. имеет место объединение ячеек.
    Selection.Tables(1).Rows(2).Select
    Selection.SplitTable
    Selection.MoveDown
'Отталкиваемся от 11 Столбца, чтобы обработать те ячейки, которые заполнены с 5 по 10 столбец
    For Each oCell In Selection.Tables(1).Columns(11).Cells
    If oCell.Shading.BackgroundPatternColor = wdColorLightYellow Then
        oCell.Select
            For x = 1 To 6
                Selection.MoveLeft Unit:=wdCell, Extend:=wdExtend
                If Selection.Text = "-" Or Selection.Characters.Count = 1 Then
                    GoTo metka
                End If
            Next
    Selection.Rows(1).Range.Font.Animation = wdAnimationMarchingRedAnts
    End If
metka:
    Next
'Заменяем цифры. В этом случае заменяются цифры, которые не идут подряд с 5 по 10 столбец.
    For Each oCell In Selection.Tables(1).Columns(5).Cells 'Теперь просматриваются не все ячейки Таблицы, а только ячейки Столбца №5.
        oCell.Select
        If oCell.Shading.BackgroundPatternColor = wdColorLightYellow And oCell.Range.Font.Animation = wdAnimationNone _
            And Selection.Characters.Count > 1 Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                    If InStr(Join(MyArray_1()), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 2
                    ElseIf InStr(Join(MyArray_2()), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 5
                    ElseIf InStr(Join(MyArray_3()), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 10
                    End If
        End If
    Next
'Обрабатываем цифры, которые идут в ячейках с 5 по 10 столбец
    For Each oCell In Selection.Tables(1).Range.Cells
        oCell.Select
        If oCell.Shading.BackgroundPatternColor = wdColorLightYellow And oCell.Range.Font.Animation = wdAnimationMarchingRedAnts _
            And Selection.Characters.Count > 1 Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                    If InStr(Join(MyArray_1()), vData_1) > 0 Then
                        vData_2 = vData_1 + 2
                        Selection.TypeText vData_2
                    ElseIf InStr(Join(MyArray_2()), vData_1) > 0 Then
                        vData_2 = vData_1 + 5
                        Selection.TypeText vData_2
                    ElseIf InStr(Join(MyArray_3()), vData_1) > 0 Then
                        vData_2 = vData_1 + 10
                        Selection.TypeText vData_2
                    End If
                    oCell.Select
                    Selection.Copy
                    Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
                    Selection.Paste
                    Selection.MoveRight
                    Selection.Cells(1).Select
                    Selection.TypeText Int(vData_2 / 2)
                    Selection.Cells(1).Select
                    Selection.Copy
                    Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
                    Selection.Paste
                    Selection.Rows(1).Range.Font.Animation = wdAnimationNone
        End If
    Next
'Переходим вверх над Таблицу, чтобы вернуть первую строку обратно
    Selection.Tables(1).Select
    Selection.MoveUp
    If Selection.Characters.Count = 1 Then
        Selection.Delete
    End If
'Убираем всю Анимацию из Документа. Я использовал Анимацию, чтобы выборочно работать с текстом и цифрами в Таблице.
    ActiveDocument.Range.Font.Animation = wdAnimationNone
End Sub

Т.е. в этих строках, что на рисунке, первые 6 цифр должны обрабатываться так же взаимосвязано, т.е. цифры 4, 5, 6 зависят от цифр 1, 2, 3? А цифры 7, 8, 9 должны увеличиваться независимо?

@vkopitsa · 15.03.2010, 07:52 **[ТС]**

Нет. В этих строках, все увеличиваются, увеличиваются как и все, числа с первава масива на 2 со второго на 5, с треева на 10

@Busine2009 · 15.03.2010, 08:12

vkopitsa,
Вот ещё один код, но он не работает правильно, если подряд заполнены все строки, сегодня больше не смогу помочь, т.к. на работу ухожу:

Visual Basic
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
Option Base 1
Dim oCell As Cell
Dim MyArray_1(19) As String
Dim MyArray_2(19) As String
Dim MyArray_3(20) As String
Dim vData_1 As Long
Dim vData_2 As Long
Sub m_1()
On Error Resume Next
'Заполняем массивы цифрами
    MyArray_1(1) = 2
    MyArray_1(2) = 4
    MyArray_1(3) = 6
    MyArray_1(4) = 8
    MyArray_1(5) = 10
    MyArray_1(6) = 12
    MyArray_1(7) = 14
    MyArray_1(8) = 16
    MyArray_1(9) = 18
    MyArray_1(10) = 20
    MyArray_1(11) = 22
    MyArray_1(12) = 24
    MyArray_1(13) = 26
    MyArray_1(14) = 28
    MyArray_1(15) = 30
    MyArray_1(16) = 32
    MyArray_1(17) = 34
    MyArray_1(18) = 36
    MyArray_1(19) = 38
        MyArray_2(1) = 5
        MyArray_2(2) = 10
        MyArray_2(3) = 15
        MyArray_2(4) = 20
        MyArray_2(5) = 25
        MyArray_2(6) = 30
        MyArray_2(7) = 35
        MyArray_2(8) = 40
        MyArray_2(9) = 45
        MyArray_2(10) = 50
        MyArray_2(11) = 55
        MyArray_2(12) = 60
        MyArray_2(13) = 65
        MyArray_2(14) = 70
        MyArray_2(15) = 75
        MyArray_2(16) = 80
        MyArray_2(17) = 85
        MyArray_2(18) = 90
        MyArray_2(19) = 95
    MyArray_3(1) = 100
    MyArray_3(2) = 110
    MyArray_3(3) = 120
    MyArray_3(4) = 130
    MyArray_3(5) = 140
    MyArray_3(6) = 150
    MyArray_3(7) = 160
    MyArray_3(8) = 170
    MyArray_3(9) = 180
    MyArray_3(10) = 190
    MyArray_3(11) = 200
    MyArray_3(12) = 210
    MyArray_3(13) = 220
    MyArray_3(14) = 230
    MyArray_3(15) = 240
    MyArray_3(16) = 250
    MyArray_3(17) = 260
    MyArray_3(18) = 270
    MyArray_3(19) = 280
    MyArray_3(20) = 290
'Предупреждаем, что курсор нужно вставить в Таблицу
    If Selection.Cells.Count = 0 Then
        MsgBox "Вставьте курсор в Таблицу, в которой надо изменить цифры!", vbCritical + vbOKOnly, "Предупреждение"
        Exit Sub
    End If
    On Error GoTo 0
'Отделяем первую строку от Таблицы. Иначе не получится работать с конкретным столбцом, т.к. имеет место объединение ячеек.
    Selection.Tables(1).Rows(2).Select
    Selection.SplitTable
    Selection.MoveDown
'Отталкиваемся от 11 Столбца, чтобы обработать те ячейки, которые заполнены с 5 по 10 столбец
    For Each oCell In Selection.Tables(1).Columns(11).Cells
    If oCell.Shading.BackgroundPatternColor = wdColorLightYellow Then
        oCell.Select
            For x = 1 To 6
            Selection.MoveLeft unit:=wdCell, Extend:=wdExtend
                If Selection.Text = "-" Or Selection.Characters.Count = 1 Then
                    Selection.Rows(1).Range.Font.Animation = wdAnimationNone
                    GoTo metka
                Else
                    Selection.Font.Animation = wdAnimationMarchingRedAnts
                End If
            Next
    End If
metka:
    Next
'Заменяем цифры. В этом случае заменяются цифры, которые не идут подряд с 5 по 10 столбец.
    For Each oCell In Selection.Tables(1).Columns(5).Cells
        oCell.Select
        If oCell.Shading.BackgroundPatternColor = wdColorLightYellow And oCell.Range.Font.Animation = wdAnimationNone _
            And Selection.Characters.Count > 1 And IsNumeric(Selection.Text) = True Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                
                    If InStr(Join(MyArray_1()), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 2
                    ElseIf InStr(Join(MyArray_2()), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 5
                    ElseIf InStr(Join(MyArray_3()), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 10
                    End If
        End If
    Next
'Обрабатываем цифры, которые идут в ячейках с 5 по 10 столбец
    For Each oCell In Selection.Tables(1).Range.Cells
        oCell.Select
        If oCell.Shading.BackgroundPatternColor = wdColorLightYellow And oCell.Range.Font.Animation = wdAnimationMarchingRedAnts _
            And Selection.Characters.Count > 1 Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                    If InStr(Join(MyArray_1()), vData_1) > 0 Then
                        vData_2 = vData_1 + 2
                        Selection.TypeText vData_2
                    ElseIf InStr(Join(MyArray_2()), vData_1) > 0 Then
                        vData_2 = vData_1 + 5
                        Selection.TypeText vData_2
                    ElseIf InStr(Join(MyArray_3()), vData_1) > 0 Then
                        vData_2 = vData_1 + 10
                        Selection.TypeText vData_2
                    End If
                    oCell.Select
                    Selection.Copy
                    Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
                    Selection.Paste
                    Selection.MoveRight
                    Selection.Cells(1).Select
                    Selection.TypeText Int(vData_2 / 2)
                    Selection.Cells(1).Select
                    Selection.Copy
                    Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
                    Selection.Paste
                    Selection.Rows(1).Range.Font.Animation = wdAnimationNone
        End If
    Next
'Переходим вверх над Таблицу, чтобы вернуть первую строку обратно
    Selection.Tables(1).Select
    Selection.MoveUp
    If Selection.Characters.Count = 1 Then
        Selection.Delete
    End If
End Sub

Ты посмотри, как я делал, может что-нибудь придумаешь.
Т.е. нас интересуют строки, которые полностью заполнены цифрами, а если какой-то цифры нет, то условие выполняется как для 6 первых ячеек?

@vkopitsa · 15.03.2010, 20:24 **[ТС]**

Нет, для условие для 6 выполняется только для 6, все остальные, если полностью заполнены или даже какой то цифры нету выполняется условие как для всех.

Добавлено через 8 часов 34 минуты
Нормально работает самый первый вариант, во втором и третьем не все числа меняются и 300 на 25. Принципы первый вариант луче, на большом документе работал 40 минут и результат хороший. Вот если бы менял числа которые в ряд идут. И есть таблицы с объединёнными ячейками. Как быть с ними?

@Busine2009 · 20.03.2010, 15:52

vkopitsa,
Вот последний вариант:

Visual Basic
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
Option Base 1
Dim oCell As Cell
Dim MyArray_1
Dim MyArray_2
Dim MyArray_3
Dim vData_1 As Long
Dim vData_2 As Long
Sub m_1()
On Error Resume Next
'Заполняем массивы цифрами
    MyArray_1 = Array(2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38)
    MyArray_2 = Array(5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95)
    MyArray_3 = Array(100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 210, 220, 230, 240, 250, 260, 270, 280, 290)
'Предупреждаем, что курсор нужно вставить в Таблицу
    If Selection.Cells.Count = 0 Then
        MsgBox "Вставьте курсор в Таблицу, в которой надо изменить цифры!", vbCritical + vbOKOnly, "Предупреждение"
        Exit Sub
    End If
    On Error GoTo 0
'Отделяем первую строку от Таблицы. Иначе не получится работать с конкретным столбцом, т.к. имеет место объединение ячеек.
    Selection.Tables(1).Rows(2).Select
    Selection.SplitTable
    Selection.MoveDown
'Отталкиваемся от 11 Столбца, чтобы обработать те ячейки, которые заполнены с 5 по 10 столбец
    For Each oCell In Selection.Tables(1).Columns(11).Cells
    If oCell.Shading.BackgroundPatternColor = wdColorLightYellow Then
        oCell.Select
            For x = 1 To 6
                Selection.MoveLeft unit:=wdCell, Extend:=wdExtend
                If IsNumeric(Selection.Text) Then
                    Selection.Font.Animation = wdAnimationMarchingRedAnts
                Else
                    Selection.Rows(1).Range.Font.Animation = wdAnimationNone
                    GoTo metka_1
                End If
            Next
    End If
metka_1:
    Next
'Снимаем Анимацию, если помимо 6 цифр в столбцах с 5 по 10 есть ещё цифры
    For Each oCell In Selection.Tables(1).Columns(10).Cells
        If oCell.Range.Font.Animation = wdAnimationMarchingRedAnts Then
            oCell.Select
                For x = 1 To 4
                    Selection.MoveRight unit:=wdCell, Extend:=wdExtend
                    If IsNumeric(Selection.Text) Then
                        Selection.Rows(1).Range.Font.Animation = wdAnimationNone
                        GoTo metka_2
                    End If
                Next
        End If
metka_2:
        Next
'Заменяем цифры. В этом случае заменяются цифры, которые не идут подряд с 5 по 10 столбец.
    For Each oCell In Selection.Tables(1).Range.Cells
        oCell.Select
        If oCell.Shading.BackgroundPatternColor = wdColorLightYellow And oCell.Range.Font.Animation = wdAnimationNone _
            And Selection.Characters.Count > 1 And IsNumeric(Left(Selection.Text, Selection.Characters.Count - 1)) = True Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                    If InStr(Join(MyArray_1), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 2
                    ElseIf InStr(Join(MyArray_2), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 5
                    ElseIf InStr(Join(MyArray_3), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 10
                    End If
        End If
    Next
'Обрабатываем цифры, которые идут в ячейках с 5 по 10 столбец
    For Each oCell In Selection.Tables(1).Columns(5).Cells
        oCell.Select
        If oCell.Range.Font.Animation = wdAnimationMarchingRedAnts Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                    If InStr(Join(MyArray_1), vData_1) > 0 Then
                        vData_2 = vData_1 + 2
                        Selection.TypeText vData_2
                    ElseIf InStr(Join(MyArray_2), vData_1) > 0 Then
                        vData_2 = vData_1 + 5
                        Selection.TypeText vData_2
                    ElseIf InStr(Join(MyArray_3), vData_1) > 0 Then
                        vData_2 = vData_1 + 10
                        Selection.TypeText vData_2
                    End If
                    oCell.Select
                    Selection.Copy
                    Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
                    Selection.Paste
                    Selection.MoveRight
                    Selection.Cells(1).Select
                    Selection.TypeText Int(vData_2 / 2)
                    Selection.Cells(1).Select
                    Selection.Copy
                    Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
                    Selection.Paste
        End If
    Next
'Переходим вверх над Таблицу, чтобы вернуть первую строку обратно
    Selection.Tables(1).Select
    Selection.MoveUp
    Selection.Paragraphs(1).Range.Select
    If Selection.Characters.Count = 1 Then
        Selection.Delete
    End If
'Убираем Анимацию во всём документе
    ActiveDocument.Range.Font.Animation = wdAnimationNone
End Sub

Напиши пример, когда ячейки объединены.

@vkopitsa · 21.03.2010, 14:38 **[ТС]**

Busine2009 большое спасибо за помощь. Считает очень хорошо. Вот пример с объединенными ячейками.

-->Пример<--

@Busine2009 · 21.03.2010, 17:52

vkopitsa,
чтобы правильно сработало, надо чтобы были соблюдены следующие условия:

Шапки должны быть одинаковыми у всех Таблиц: 1, 2 строки.
Количество столбцов должно быть одинаково.
Только цифры, с которыми работаем, должны быть светло-жёлтые.

Visual Basic
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
Option Base 1
Dim oCell As Cell
Dim MyArray_1
Dim MyArray_2
Dim MyArray_3
Dim vData_1 As Long
Dim vData_2 As Long
Sub m_1()
On Error Resume Next
x = 0
'Заполняем массивы цифрами
    MyArray_1 = Array(2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38)
    MyArray_2 = Array(5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95)
    MyArray_3 = Array(100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 210, 220, 230, 240, 250, 260, 270, 280, 290)
'Предупреждаем, что курсор нужно вставить в Таблицу
    If Selection.Cells.Count = 0 Then
        MsgBox "Вставьте курсор в Таблицу, в которой надо изменить цифры!", vbCritical + vbOKOnly, "Предупреждение"
        Exit Sub
    End If
    On Error GoTo 0
'Выделяем Анимацией 5 столбец, чтобы потом от него отталкиваться (чёрные муравьи)
    Selection.Tables(1).Cell(1, 1).Select
    Selection.MoveDown
    Selection.MoveRight unit:=wdCell, Count:=4
    Selection.SelectColumn
    Selection.Font.Animation = wdAnimationMarchingBlackAnts
'Если ячейки с 5 по 10 заполнены цирфами, то выделяем их Анимацией (красные муравьи)
    With Selection.Tables(1).Range.Find
        .ClearFormatting
        .Text = "?"
        .Font.Animation = wdAnimationMarchingBlackAnts
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            .Parent.Select
            Selection.Cells(1).Select
                If Selection.Cells(1).Shading.BackgroundPatternColor = wdColorLightYellow Then
                    For x = 1 To 6
                        If IsNumeric(Left(Selection.Text, Selection.Characters.Count - 1)) And x < 6 Then
                            Selection.Font.Animation = wdAnimationMarchingRedAnts
                        ElseIf IsNumeric(Left(Selection.Text, Selection.Characters.Count - 1)) And x = 6 Then
                            Selection.Font.Animation = wdAnimationBlinkingBackground
                        Else
                            Selection.SelectRow
                            Selection.Font.Animation = wdAnimationNone
                            GoTo metka_1
                        End If
                        Selection.MoveRight unit:=wdCell, Extend:=wdExtend
                    Next
                End If
metka_1:
        Wend
    End With
'Снимаем Анимацию, если помимо 6 цифр в столбцах с 5 по 10 есть ещё цифры
    With Selection.Tables(1).Range.Find
        .ClearFormatting
        .Text = "?"
        .Font.Animation = wdAnimationBlinkingBackground
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            .Parent.Select
            Selection.Cells(1).Select
            Selection.Font.Animation = wdAnimationMarchingRedAnts
                For x = 1 To 4
                    Selection.MoveRight unit:=wdCell, Extend:=wdExtend
                    If IsNumeric(Selection.Text) = True Then
                        Selection.SelectRow
                        Selection.Font.Animation = wdAnimationNone
                        GoTo metka_2
                    End If
                Next
metka_2:
        Wend
    End With
'Заменяем цифры. В этом случае заменяются цифры, которые не идут подряд с 5 по 10 столбец.
    For Each oCell In Selection.Tables(1).Range.Cells
        oCell.Select
        If oCell.Shading.BackgroundPatternColor = wdColorLightYellow And oCell.Range.Font.Animation = wdAnimationNone _
            And Selection.Characters.Count > 1 And IsNumeric(Left(Selection.Text, Selection.Characters.Count - 1)) = True Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                    If InStr(Join(MyArray_1), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 2
                    ElseIf InStr(Join(MyArray_2), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 5
                    ElseIf InStr(Join(MyArray_3), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 10
                    End If
        End If
    Next
'Увеличиваем цифры, которые идут в ячейках с 5 по 10 столбец
    With Selection.Tables(1).Range.Find
        .ClearFormatting
        .Text = "?"
        .Font.Animation = wdAnimationMarchingRedAnts
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            .Parent.Select
            Selection.Cells(1).Select
            vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
            If InStr(Join(MyArray_1), vData_1) > 0 Then
                vData_2 = vData_1 + 2
                Selection.TypeText vData_2
            ElseIf InStr(Join(MyArray_2), vData_1) > 0 Then
                vData_2 = vData_1 + 5
                Selection.TypeText vData_2
            ElseIf InStr(Join(MyArray_3), vData_1) > 0 Then
                vData_2 = vData_1 + 10
                Selection.TypeText vData_2
            End If
            Selection.Cells(1).Select
            Selection.Copy
            Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
            Selection.Paste
            Selection.Font.Animation = wdAnimationNone
            Selection.MoveRight
            Selection.Cells(1).Select
            Selection.TypeText Int(vData_2 / 2)
            Selection.Cells(1).Select
            Selection.Copy
            Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
            Selection.Paste
            Selection.Font.Animation = wdAnimationNone
        Wend
    End With
'Убираем Анимацию во всём документе
    ActiveDocument.Range.Font.Animation = wdAnimationNone
'Переходим в начало Таблицы
    Selection.Tables(1).Select
    Selection.MoveUp
End Sub

@vkopitsa · 22.03.2010, 10:05 **[ТС]**

Всё работает очень хорошо, большое спасибо. Только некорректно пересчитывает вот такие цифры. Еще раз спасибо.

-->Пример<--

@Busine2009 · 22.03.2010, 22:40

vkopitsa,
какие строки?

@vkopitsa · 23.03.2010, 09:09 **[ТС]**

Де 300 300 300 300 300 300

Некорректно считает.

@Busine2009 · 24.03.2010, 07:32

vkopitsa,
Я так понимаю, что если идёт 6 чисел подряд, а первые 3 числа 300, то эту строку обрабатывать не надо, т.к. это предел. Попробуй использовать этот код:

Visual Basic
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
Option Base 1
Dim oCell As Cell
Dim MyArray_1
Dim MyArray_2
Dim MyArray_3
Dim vData_1 As Long
Dim vData_2 As Long
Sub m_1()
On Error Resume Next
x = 0
'Заполняем массивы цифрами
    MyArray_1 = Array(2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38)
    MyArray_2 = Array(5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95)
    MyArray_3 = Array(100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 210, 220, 230, 240, 250, 260, 270, 280, 290)
'Предупреждаем, что курсор нужно вставить в Таблицу
    If Selection.Cells.Count = 0 Then
        MsgBox "Вставьте курсор в Таблицу, в которой надо изменить цифры!", vbCritical + vbOKOnly, "Предупреждение"
        Exit Sub
    End If
    On Error GoTo 0
'Выделяем Анимацией 5 столбец, чтобы потом от него отталкиваться (чёрные муравьи)
    Selection.Tables(1).Cell(1, 1).Select
    Selection.MoveDown
    Selection.MoveRight unit:=wdCell, Count:=4
    Selection.SelectColumn
    Selection.Font.Animation = wdAnimationMarchingBlackAnts
'Если ячейки с 5 по 10 заполнены цирфами, то выделяем их Анимацией (красные муравьи)
    With Selection.Tables(1).Range.Find
        .ClearFormatting
        .Text = "?"
        .Font.Animation = wdAnimationMarchingBlackAnts
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            .Parent.Select
            Selection.Cells(1).Select
                If Selection.Cells(1).Shading.BackgroundPatternColor = wdColorLightYellow Then
                    For x = 1 To 6
                        If IsNumeric(Left(Selection.Text, Selection.Characters.Count - 1)) And x < 6 Then
                            Selection.Font.Animation = wdAnimationMarchingRedAnts
                        ElseIf IsNumeric(Left(Selection.Text, Selection.Characters.Count - 1)) And x = 6 Then
                            Selection.Font.Animation = wdAnimationBlinkingBackground
                        Else
                            Selection.SelectRow
                            Selection.Font.Animation = wdAnimationNone
                            GoTo metka_1
                        End If
                        Selection.MoveRight unit:=wdCell, Extend:=wdExtend
                    Next
                End If
metka_1:
        Wend
    End With
'Снимаем Анимацию, если помимо 6 цифр в столбцах с 5 по 10 есть ещё цифры
    With Selection.Tables(1).Range.Find
        .ClearFormatting
        .Text = "?"
        .Font.Animation = wdAnimationBlinkingBackground
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            .Parent.Select
            Selection.Cells(1).Select
            Selection.Font.Animation = wdAnimationMarchingRedAnts
                For x = 1 To 4
                    Selection.MoveRight unit:=wdCell, Extend:=wdExtend
                    If IsNumeric(Selection.Text) = True Then
                        Selection.SelectRow
                        Selection.Font.Animation = wdAnimationNone
                        GoTo metka_2
                    End If
                Next
metka_2:
        Wend
    End With
'Заменяем цифры. В этом случае заменяются цифры, которые не идут подряд с 5 по 10 столбец.
    For Each oCell In Selection.Tables(1).Range.Cells
        oCell.Select
        If oCell.Shading.BackgroundPatternColor = wdColorLightYellow And oCell.Range.Font.Animation = wdAnimationNone _
            And Selection.Characters.Count > 1 And IsNumeric(Left(Selection.Text, Selection.Characters.Count - 1)) = True Then
                vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
                    If InStr(Join(MyArray_1), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 2
                    ElseIf InStr(Join(MyArray_2), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 5
                    ElseIf InStr(Join(MyArray_3), vData_1) > 0 Then
                        Selection.TypeText vData_1 + 10
                    End If
        End If
    Next
'Увеличиваем цифры, которые идут в ячейках с 5 по 10 столбец
    With Selection.Tables(1).Range.Find
        .ClearFormatting
        .Text = "?"
        .Font.Animation = wdAnimationMarchingRedAnts
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            .Parent.Select
            Selection.Cells(1).Select
            vData_1 = Left(Selection.Text, Selection.Characters.Count - 1)
            If InStr(Join(MyArray_1), vData_1) > 0 Then
                vData_2 = vData_1 + 2
                Selection.TypeText vData_2
            ElseIf InStr(Join(MyArray_2), vData_1) > 0 Then
                vData_2 = vData_1 + 5
                Selection.TypeText vData_2
            ElseIf InStr(Join(MyArray_3), vData_1) > 0 Then
                vData_2 = vData_1 + 10
                Selection.TypeText vData_2
            ElseIf vData_1 = 300 Then
                Selection.SelectRow
                Selection.Font.Animation = wdAnimationNone
                GoTo metka_3
            End If
            Selection.Cells(1).Select
            Selection.Copy
            Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
            Selection.Paste
            Selection.Font.Animation = wdAnimationNone
            Selection.MoveRight
            Selection.Cells(1).Select
            Selection.TypeText Int(vData_2 / 2)
            Selection.Cells(1).Select
            Selection.Copy
            Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
            Selection.Paste
            Selection.Font.Animation = wdAnimationNone
metka_3:
        Wend
    End With
'Убираем Анимацию во всём документе
    ActiveDocument.Range.Font.Animation = wdAnimationNone
'Переходим в начало Таблицы
    Selection.Tables(1).Select
    Selection.MoveUp
End Sub

@vkopitsa · 26.03.2010, 10:01 **[ТС]**

Busine2009, большое спасибо, все работает классно.

Новые блоги и статьи Все статьи Все блоги /
Nekobox - outbounds[0].transport: unknown transport type: raw damix 01.10.2026 Фикс ошибки Правым кликом по серверу -> отладочная информация -> edit Заменить "net": "raw", на "net": "tcp", Нажать кнопку reload.	Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .	Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .	Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .
Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .	Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .	Программа опроса у.з. расходомера SLS-720F Argus19 02.09.2026 Программа опроса у. з. расходомера SLS-720F Программа опрашивает один раз в минуту три ультразвуковых расходомера SLS-720F через интерфейс RS-485 по протоколу Modbus RTU. Опрашиваются регистры. . .	Hyper-V: Компьютер должен поддерживать доверенный платформенный модуль 2.0. Maks 31.08.2026 При установке Windows 11 на виртуальную машину Hyper-V 2-го поколения вылезла такая ошибка: Решение: в параметрах виртуальной машины, в разделе "Безопасность" (Security) активировать флаг. . .

@Busine2009 2309 / 1541 / 115 Регистрация: 13.06.2009 Сообщений: 5,575
	14.03.2010, 21:42
	vkopitsa, тебя не пугает, что округление всегда в меньшую сторону? Добавлено через 49 минут В 1-ый Массив может быть добавить цифры 36 и 38? 1

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	15.03.2010, 01:00 [ТС]
	Наоборот, то что нужно. Спасибо большое. 0

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	15.03.2010, 01:13 [ТС]
	Ище есть такие ячейки, как быть с ними. Миниатюры 0

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	15.03.2010, 07:52 [ТС]
	Нет. В этих строках, все увеличиваются, увеличиваются как и все, числа с первава масива на 2 со второго на 5, с треева на 10 0

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	15.03.2010, 20:24 [ТС]
	Нет, для условие для 6 выполняется только для 6, все остальные, если полностью заполнены или даже какой то цифры нету выполняется условие как для всех. Добавлено через 8 часов 34 минуты Нормально работает самый первый вариант, во втором и третьем не все числа меняются и 300 на 25. Принципы первый вариант луче, на большом документе работал 40 минут и результат хороший. Вот если бы менял числа которые в ряд идут. И есть таблицы с объединёнными ячейками. Как быть с ними? 0

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	21.03.2010, 14:38 [ТС]
	Busine2009 большое спасибо за помощь. Считает очень хорошо. Вот пример с объединенными ячейками. -->Пример<-- 0

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	22.03.2010, 10:05 [ТС]
	Всё работает очень хорошо, большое спасибо. Только некорректно пересчитывает вот такие цифры. Еще раз спасибо. -->Пример<-- 0

@Busine2009 2309 / 1541 / 115 Регистрация: 13.06.2009 Сообщений: 5,575
	22.03.2010, 22:40
	vkopitsa, какие строки? 0

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	23.03.2010, 09:09 [ТС]
	Де 300 300 300 300 300 300 Некорректно считает. 0

@vkopitsa 0 / 0 / 0 Регистрация: 11.03.2010 Сообщений: 17
	26.03.2010, 10:01 [ТС]
	Busine2009, большое спасибо, все работает классно. 0