Непредсказуемая производительность процедуры Excel VBA

@babken76 · Регистрация: 11.10.2010

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

Существует процедура в которой требуется сложить все ячейки, всех листов, всех файлов в заданном диапазоне. Я делаю это так:

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
Sub total_rate_book()
On Error GoTo errhandle
Application.Visible = False
wait_frm.Show
wait_frm.Repaint
Call Module3.uni_protect(0, 2)
Set fs = CreateObject("Scripting.FileSystemObject")
ws = Worksheets("Настройка").Cells(4, 2).Value
erase_old = sum_or_del_all(1, ThisWorkbook.Worksheets.Count, 3)
 
''''
Set fs = Application.FileSearch
With fs
    .LookIn = Cells(4, 2).Value
    .SearchSubFolders = True
    .Filename = "*.xls"
    If .Execute() > 0 Then
        Application.EnableEvents = False
        Application.DisplayAlerts = False
        For i = 1 To .FoundFiles.Count
            If Mid(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "") + 1) <> Mid((Left(.FoundFiles(i), Len(.FoundFiles(i)) - (InStrRev(.FoundFiles(i), "") - 1))), (InStrRev((Left(.FoundFiles(i), Len(.FoundFiles(i)) - (InStrRev(.FoundFiles(i), "") - 1))), "") + 1)) Then
                Workbooks.Open .FoundFiles(i)
                'вызов функции сложения
                is_it_cool = sum_or_del_all(1, ThisWorkbook.Worksheets.Count, 1)
                ActiveWindow.Close savechanges:=False
            End If
        Next i
        Application.EnableEvents = True
        Application.DisplayAlerts = True
    Else
        err3 = MsgBox("Не найдено ни одного файла в пути: " & ws, vbCritical, "Ошибка!", 0, 0)
        Application.EnableEvents = True
        wait_frm.Hide
        Application.Visible = True
        ThisWorkbook.Close savechanges:=False
        Exit Sub
    End If
End With
 
''''
wait_frm.Hide
Application.Visible = True
Call Module3.uni_protect(1, 1)
Exit Sub
 
errhandle:
Call Module3.show_err(Err)
End Sub
 
'функция sum_or_del=1 перебор и суммирование всех числовых полей
'заданного диапазона всех листов книг 
'sum_or_del=2 очистка диапазона ручного ввода в текущем файле
'sum_or_del=3 очистка диапазона ручного ввода и всех числовых ячеек в листах справа от
'листа Настройка в текущем файле
 
Function sum_or_del_all(first As Integer, last As Integer, sum_or_del As Integer) As Boolean
On Error GoTo ErrorHandler
Dim f As Object
 
For i = first To last
  Set r_sh = Application.ThisWorkbook.Worksheets(i) 'текущий лист книги приемника
  Set s_sh = ActiveWorkbook.Worksheets(i) 'текущий лист книги источника
 
'вариант 2 - в диапазоне сканирования суммируем все ячейки(за исключением форматов общий и текстовый)
'с голубой заливкой, и все числовые ячейки(за исключением форматов общий и текстовый)
'листов с индексом больше чем у листа Настройка
    If Worksheets(i).Name <> "Настройка" Then
        If sum_or_del = 1 Then
            For Each f In r_sh.Range(Module3.scan_diap)
                If Application.IsNumber(f.Value) Then
                    If Len(f) < 250 Then
                        If f.Interior.ColorIndex = 34 Or i > num_tune_sheet Then
                            If r_sh.Name = ActiveWorkbook.Worksheets(i).Name Then
                                r_sh.Cells(f.Row, f.Column).Value = r_sh.Cells(f.Row, f.Column).Value + s_sh.Cells(f.Row, f.Column).Value
                            Else
                                r_sh.Cells(f.Row, f.Column).Value = r_sh.Cells(f.Row, f.Column).Value + ActiveWorkbook.Worksheets(r_sh.Name).Cells(f.Row, f.Column).Value
                            End If
                        End If
                    End If
                End If
            Next f
        Else ' очистка дника
 
'вариант 2 - в диапазоне сканирования суммируем все ячейки(за исключением форматов общий и текстовый)
 
'с голубой заливкой, и все числовые ячейки(за исключением форматов общий и текстовый)
'листов с индексом больше чем у листа Настройка
    If Worksheets(i).Name <> "Настройка" Then
        If sum_or_del = 1 Then
            For Each f In r_sh.Range(Module3.scan_diap)
                If Application.IsNumber(f.Value) Then
                    If Len(f) < 250 Then
                        If f.Interior.ColorIndex = 34 Or i > num_tune_sheet Then
                            If flag_ochistki = False Then
                                r_sh.Cells(f.Row, f.Column).Value = 0
                            End If
                            If r_sh.Name = ActiveWorkbook.Worksheets(i).Name Then
                                r_sh.Cells(f.Row, f.Column).Value = r_sh.Cells(f.Row, f.Column).Value + s_sh.Cells(f.Row, f.Column).Value
                            Else
                                r_sh.Cells(f.Row, f.Column).Value = r_sh.Cells(f.Row, f.Column).Value + ActiveWorkbook.Worksheets(r_sh.Name).Cells(f.Row, f.Column).Value
                            End If
                        End If
                    End If
                End If
            Next f
        End If
    End If
Next i
sum_or_del_all = True
Exit Function
 
ErrorHandler:
 
info_str = " Книга: " & ActiveWorkbook.Name & " Лист: " & _
ActiveWorkbook.Worksheets(i).Name & " Ячейка: " & r_sh.Cells(f.Row, f.Column).Address
Call Module3.show_err(Err, info_str)
End Function

Однако это не помогло.

Пока, единственным способом локализации проблемы, я вижу в последовательном комментировании блоков условных операторов в цикле, и тестировании в таком виде, с проведением хронометража. Какие еще есть ошибки и/или неточности в коде Вы видете?

С уважением,

@babken76 · 19.02.2007, 22:44 **[ТС]**

Кажется нашел.

Visual Basic
1
2
3
4
5
6
7
8
9
'Если сменить 
If flag_ochistki = False Then
  r_sh.Cells(f.Row, f.Column).Value
End If
 
'на
If flag_ochistki = False Then
   f.Value = 0
End If

,то вся прога начинает работать ~в 10 раз быстрее.

С уважением,

20.02.2007, 06:59

babken76 (19.02.2007)
Кажется нашел.

уже б выкладывал файл целиком, а то тяжковато тут столько кода смотреть.

@babken76 · 20.02.2007, 14:34 **[ТС]**

to fess: Сам файл весит 4 метра и не жмется. Эффект увеличения производительности, который я описал в прошлом сообщении оказался тоже весьма не постоянным. На компе заказчика получилось ~40 минут против 5 на моей машине, хотя мощность железа вроде бы одинаковая. Вообще, раз на раз не приходится.

С уважением,

@babken76 · 20.02.2007, 22:35 **[ТС]**

Переделал алгоритм. Теперь, по крайней мере на тех данных, что я использовал для тестирования все ок.

VB.NET
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
'module2
 
'Свод регистров налогового учета.
 
Public flag_ochistki As Boolean
 
Sub total_rate_book()
 
On Error GoTo errhandle
 
Application.Visible = False
 
wait_frm.Show
 
wait_frm.Repaint
 
Call Module3.uni_protect(0, 2)
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
ws = Worksheets("Настройка").Cells(4, 2).Value
 
'erase_old = sum_or_del_all(1, ThisWorkbook.Worksheets.Count, 3)
 
''''
 
Set fs = Application.FileSearch
 
With fs
 
    .LookIn = Cells(4, 2).Value
 
    .SearchSubFolders = True
 
    .Filename = "*.xls"
 
    If .Execute() > 0 Then
 
        Application.EnableEvents = False
 
        For i = 1 To .FoundFiles.Count
 
            If Mid(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "") + 1) <> Mid((Left(.FoundFiles(i), Len(.FoundFiles(i)) - (InStrRev(.FoundFiles(i), "") - 1))), (InStrRev((Left(.FoundFiles(i), Len(.FoundFiles(i)) - (InStrRev(.FoundFiles(i), "") - 1))), "") + 1)) Then
 
                Workbooks.Open .FoundFiles(i)
 
                wait_frm.wb_name = ActiveWorkbook.Name
 
                wait_frm.Repaint
 
                'вызов функции сложения листов ДО листа Настройка
 
                is_it_cool = sum_or_del_all(1, num_tune_sheet - 1, 1)
 
                'вызов функции сложения листов ПОСЛЕ листа Настройка
 
                is_it_cool = sum_or_del_all(num_tune_sheet + 1, ThisWorkbook.Worksheets.Count, 4)
 
                ActiveWindow.Close savechanges:=False
 
                flag_ochistki = True
 
            End If
 
        Next i
 
        Application.EnableEvents = True
 
        
 
    Else
 
        err3 = MsgBox("Не найдено ни одного файла в пути: " & ws, vbCritical, "Ошибка!", 0, 0)
 
        Application.EnableEvents = True
 
        wait_frm.Hide
 
        Application.Visible = True
 
        ThisWorkbook.Close savechanges:=False
 
        Exit Sub
 
    End If
 
End With
 
''''
 
wait_frm.Hide
 
Application.Visible = True
 
Call Module3.uni_protect(1, 1)
 
Exit Sub
 
 
 
errhandle:
 
Call Module3.show_err(Err)
 
End Sub
 
'функция sum_or_del=1 перебор и суммирование всех числовых полей
 
'заданного диапазона всех листов книг регистров налогового учета
 
'sum_or_del=2 очистка диапазона ручного ввода в текущем файле
 
'sum_or_del=3 очистка диапазона ручного ввода и всех числовых ячеек в листах справа от
 
'листа Настройка в текущем файле
 
Function sum_or_del_all(first As Integer, last As Integer, sum_or_del As Integer) As Boolean
 
On Error GoTo ErrorHandler
 
Dim f As Object
 
'Application.Visible = True 'debug
 
Application.DisplayAlerts = False '?
 
For i = first To last
 
 
 
Set r_sh = Application.ThisWorkbook.Worksheets(i) 'текущий лист книги приемника
 
'Set s_sh = ActiveWorkbook.Worksheets(i) 'текущий лист книги источника
 
wait_frm.ws_name = r_sh.Name
 
wait_frm.Repaint
 
'вариант 2 - в диапазоне сканирования суммируем все ячейки(за исключением форматов общий и текстовый)
 
'с голубой заливкой, и все числовые ячейки(за исключением форматов общий и текстовый)
 
'листов с индексом больше чем у листа Настройка
 
    If sum_or_del = 1 Then 'суммирование листов ДО листа настройка
 
        For Each f In r_sh.Range(Module3.scan_diap)
 
            If f.Interior.ColorIndex = 34 Then ' Or i > num_tune_sheet
 
                If Application.IsNumber(f.Value) Then ' And Len(f) < 250
 
                    If flag_ochistki = False Then
 
                        f.Value = 0
 
                    End If

Новые блоги и статьи Все статьи Все блоги /
Знаешь почему 90% людей редко бывают счастливыми? kumehtar 14.04.2026 Потому что они ждут. Ждут выходных, ждут отпуска, ждут удачного момента. . . а удачный момент так и не приходит.	Фиксация колонок в отчете СКД Maks 14.04.2026 Фиксация колонок в СКД отчета типа Таблица. Задача: зафиксировать три левых колонки в отчете. Процедура ПриКомпоновкеРезультата(ДокументРезультат, ДанныеРасшифровки, СтандартнаяОбработка) / / . . .	Настройки VS Code Loafer 13.04.2026 { "cmake. configureOnOpen": false, "diffEditor. ignoreTrimWhitespace": true, "editor. guides. bracketPairs": "active", "extensions. ignoreRecommendations": true, . . .	Оптимизация кода на разграничение прав доступа к элементам формы Maks 13.04.2026 Алгоритм из решения ниже реализован на нетиповом документе, разработанного в конфигурации КА2. Задачи, как таковой, поставлено не было, проделанное ниже исключительно моя инициатива. Было так:. . .
Контроль заполнения и очистка дат в зависимости от значения перечислений Maks 12.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "ПланированиеПерсонала", разработанного в конфигурации КА2. Задача: реализовать контроль корректности заполнения дат назначения. . .	Архитектура слоя интернета для сервера-слоя. Hrethgir 11.04.2026 В продолжение https:/ / www. cyberforum. ru/ blogs/ 223907/ 10860. html Знаешь что я подумал? Раз мы все источники пишем в голове ветки, то ничего не мешает добавить в голову такой источник, который сам. . .	Подстановка значения реквизита справочника в табличную часть документа Maks 10.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "ПланированиеПерсонала", разработанного в конфигурации КА2. Задача: при выборе сотрудника (справочник Сотрудники) в ТЧ документа. . .	Очистка реквизитов документа при копировании Maks 09.04.2026 Алгоритм из решения ниже применим как для типовых, так и для нетиповых документов на самых различных конфигурациях. Задача: при копировании документа очищать определенные реквизиты и табличную. . .

@babken76 0 / 0 / 1 Регистрация: 11.10.2010 Сообщений: 363
	20.02.2007, 14:34 [ТС]
	to fess: Сам файл весит 4 метра и не жмется. Эффект увеличения производительности, который я описал в прошлом сообщении оказался тоже весьма не постоянным. На компе заказчика получилось ~40 минут против 5 на моей машине, хотя мощность железа вроде бы одинаковая. Вообще, раз на раз не приходится. С уважением, 0