Оптимизация макроса для слабого железа

@IndeecFOX · Регистрация: 20.02.2018

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

Здравствуйте. Нужна небольшая помощь в оптимизации маленького макроса.
Смысл: Он берёт данные из "Прогноз.xls" (Нужны только строки с товарами, пустые не нужны), копирует их в книгу "Задачи на день АВТ.xls" на лист "Прогноз", где требуется в начала списка вывести сначала товары у который последний день реализации сегодня, а затем уже после этих строк остальные, которые идут по убыванию значения столбца "Продажа в день", при этом товары с сегодняшним днём выделить жирным.
Мой макрос больше всего времени затрачивает на преобразование текст в столбце "Последний день реализации" в дату, путём перевставки с Cdate() и на делении столбца "Количество товара", т.к. там количество копируется как: 3 000, вместо 3.
Если не преобразовать текст в дату, то нельзя выполнить по ней сортировку и не работает вычисление в последнем столбце.
Думаю что cdate который используется в цикле на 200 строк можно как-то заменить на более шустрый алгоритм. Но я не так силён. Приму любые предложения, советы. Файлы прилагаю. Примерное время выполнения на данный момент на слабом ПК: 25сек. Спасибо.
macr.zip

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
Sub Макрос1()
 Sheets("Прогноз").Select
 'Очистка листа перед копированием новых данных
 Range("A2:K300").ClearContents
    Columns("A:L").Select
    Range("L1").Activate
    Selection.Font.Bold = True
    Selection.Font.Bold = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
 'Копируем данные с книги
 thisWB = ActiveWorkbook.Name
 Workbooks.Open (ActiveWorkbook.Path & "\Прогноз.xls")
 With Workbooks("Прогноз.xls").Sheets("Sheet1").Range(Cells(5, 1), Cells(200, 11))
  Workbooks(thisWB).Worksheets("Прогноз").Range("a2").Resize(195, 11) = .Value
 End With
 Workbooks("Прогноз.xls").Close
'Фиксим количество, даты
 For i = 2 To 200
  If Sheets("Прогноз").Cells(i, 7) <> "" Then
   Sheets("Прогноз").Cells(i, 8) = Sheets("Прогноз").Cells(i, 8) / 1000
   Sheets("Прогноз").Cells(i, 7) = CDate(Sheets("Прогноз").Cells(i, 7))
  End If
 Next i
 'Удаляем вчерашний день
 For i = 2 To 10
  If Cells(i, 7) = Date - 1 Then
   Range(Cells(i, 1), Cells(i, 11)).ClearContents
  Else
   i = 10
  End If
 Next i
'Сортировка по дате что бы сегодняшний день был впереди фикс
 Range(Cells(2, 1), Cells(50, 12)).Select
 ActiveWorkbook.Worksheets("Прогноз").Sort.SortFields.clear
 ActiveWorkbook.Worksheets("Прогноз").Sort.SortFields.Add Key:=Range("G1"), _
 SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 With ActiveWorkbook.Worksheets("Прогноз").Sort
  .SetRange Range(Cells(2, 1), Cells(50, 12))
  .Header = xlNo
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
 End With
 'Выделяем сегодняшнмй день жирным
 today = 2
 For i = 2 To 10
  Range(Cells(i, 1), Cells(10, 12)).Font.Bold = False
  If Cells(i, 7) = Date Then
    today = i + 1
  Else
   i = 10
  End If
 Next i
 If today > 2 Then
      Range(Cells(2, 1), Cells(today - 1, 12)).Font.Bold = True
 End If
 'Удаляем яйца
 For i = 2 To 200
  If Left(Cells(i, 4), 6) = "Яйцо к" Then
    Range(Cells(i, 1), Cells(i, 11)).ClearContents
  End If
 Next i
 'Соритровка по уменьшению в день
 Range(Cells(today, 12), Cells(210, 12)).Select
 ActiveWorkbook.Worksheets("Прогноз").Sort.SortFields.clear
 ActiveWorkbook.Worksheets("Прогноз").Sort.SortFields.Add Key:=Range("L1"), _
 SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
 With ActiveWorkbook.Worksheets("Прогноз").Sort
  .SetRange Range(Cells(today, 1), Cells(210, 12))
  .Header = xlNo
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
 End With
 'выделяем жирным на основном листе текущий день
 Sheets("Задачи на день").Select
 Sheets("Задачи на день").Range(Cells(20, 1), Cells(26, 1)).Font.Bold = False
 If today > 2 Then
  Sheets("Задачи на день").Range(Cells(20, 1), Cells(17 + today, 1)).Font.Bold = True
 End If
End Sub

@КостяФедореев · 02.09.2019, 17:56

IndeecFOX, около 1 секунды

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
Sub RRR()
a = Timer
Application.ScreenUpdating = False
Dim r As Range
Dim Cell As Range
Dim div_mt As Double
AWB = ActiveWorkbook.Name
Workbooks.Open (ActiveWorkbook.Path & "\Прогноз.xls")
With Workbooks("Прогноз.xls").Sheets("Sheet1").Range(Cells(5, 1), Cells(200, 11))
     Workbooks(AWB).Worksheets("Прогноз").Range("A2:K300").ClearContents
     Workbooks(AWB).Worksheets("Прогноз").Range("a2").Resize(195, 11) = .Value
End With
Workbooks("Прогноз.xls").Close
Sheets("Прогноз").Activate
lRow = Sheets("Прогноз").Cells(Rows.Count, "E").End(xlUp).Row
div_kg = 1000
With ActiveSheet
     
     Set r = Intersect(.UsedRange, .[A:K]).Offset(1)
         o = r.Row
         r.FormulaLocal = r.FormulaLocal
         
     For Each Cell In Range("H2:H" & lRow)
              o = Cell.Row
              Cell = Cell / div_kg
              Range(Cells(o, 1), Cells(o, 12)).Font.Bold = False
                If Cells(o, 7) = Date Then
                   Range(Cells(o, 1), Cells(o, 12)).Font.Bold = True
                End If
                    If Cells(o, 7) < Date Then
                       Range(Cells(o, 1), Cells(o, 11)).ClearContents
                    End If
                        If Left(Cells(o, 4), 6) = "Яйцо к" Then
                           Range(Cells(o, 1), Cells(o, 11)).ClearContents
                        End If
    Next Cell
End With
 
With ActiveSheet.Sort
  .SetRange Range("A2:L" & lRow)
  .Apply
End With
  Sheets("Задачи на день").Select
  Sheets("Задачи на день").Range(Cells(20, 1), Cells(26, 1)).Font.Bold = False
        If today > 2 Then
           Sheets("Задачи на день").Range(Cells(20, 1), Cells(17 + today, 1)).Font.Bold = True
        End If
Application.ScreenUpdating = True
 
    MsgBox Timer - a
 End Sub

@IndeecFOX · 03.09.2019, 02:08 **[ТС]**

Application.ScreenUpdating - полезная функция о которой не знал. Вот спасибо за неё)

Новые блоги и статьи Все статьи Все блоги /
Как дизайн сайта влияет на конверсию: 7 решений, которые реально повышают заявки Neotwalker 08.03.2026 Многие до сих пор воспринимают дизайн сайта как “красивую оболочку”. На практике всё иначе: дизайн напрямую влияет на то, оставит человек заявку или уйдёт через несколько секунд. Даже если у вас. . .	Модульная разработка через nuget packages DevAlt 07.03.2026 Сложившийся в . Net-среде способ разработки чаще всего предполагает монорепозиторий в котором находятся все исходники. При создании нового решения, мы просто добавляем нужные проекты и имеем. . .	Модульный подход на примере F# DevAlt 06.03.2026 В блоге дяди Боба наткнулся на такое определение: В этой книге («Подход, основанный на вариантах использования») Ивар утверждает, что архитектура программного обеспечения — это структуры,. . .	Управление камерой с помощью скрипта OrbitControls.js на Three.js: Вращение, зум и панорамирование 8Observer8 05.03.2026 Содержание блога Финальная демка в браузере работает на Desktop и мобильных браузерах. Итоговый код: orbit-controls-threejs-js. zip. Сканируйте QR-код на мобильном. Вращайте камеру одним пальцем,. . .
SDL3 для Web (WebAssembly): Синхронизация спрайтов SDL3 и тел Box2D 8Observer8 04.03.2026 Содержание блога Финальная демка в браузере. Итоговый код: finish-sync-physics-sprites-sdl3-c. zip На первой гифке отладочные линии отключены, а на второй включены:. . .	SDL3 для Web (WebAssembly): Идентификация объектов на Box2D v3 - использование userData и событий коллизий 8Observer8 02.03.2026 Содержание блога Финальная демка в браузере. Итоговый код: finish-collision-events-sdl3-c. zip Сканируйте QR-код на мобильном и вы увидите, что появится джойстик для управления главным героем. . . .	Реалии Hrethgir 01.03.2026 Нет, я не закончил до сих пор симулятор. Эта задача сложнее. Не получилось уйти в плавсостав, но оно и к лучшему, возможно. Точнее получалось - но сварщиком в палубную команду, а это значит, в моём. . .	Ритм жизни kumehtar 27.02.2026 Иногда приходится жить в ритме, где дел становится всё больше, а вовлечения в происходящее — всё меньше. Плотный график не даёт вниманию закрепиться ни на одном событии. Утро начинается с быстрых,. . .

@IndeecFOX 0 / 0 / 0 Регистрация: 20.02.2018 Сообщений: 2
	03.09.2019, 02:08 [ТС]
	Application.ScreenUpdating - полезная функция о которой не знал. Вот спасибо за неё) 0

Оптимизация макроса для слабого железа

Решение