Оптимизация макроса в Excel

@Дмитрий111111 · Регистрация: 15.01.2015

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

Приветствую! Возникла небольшая проблема, макрос работает идеально, но с большим объемом информации не справляется, для этого разделил на 3 кнопки. Нужен совет для оптимизации этого макроса, заранее спасибо.

Visual Basic

Sub w1sws()
 
Dim a As Range
Dim options As Long
Dim opt As Long
Dim o As Long
Dim Results As Long
Dim re As Long
Dim KeywordsC As Long
Dim KeywordsC2 As Long
Dim KeywordsC3 As Long
Dim ResultFields As Long
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single
    Dim pi As New ProgressIndicator
    
    
pi.Show "Progress"  'Для вывода прогрессбара
KeywordsC = 2
KeywordsC2 = 3
KeywordsC3 = 4
options = Worksheets(1).Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
'заполненные строки
opt = options - 1
'-1на строка с заголовком
o = opt + 5
'с 5й начинаеться
' такая схема не учитывает кол-во пустых строк (10заполнил 1 пропустил ищет 11 клеток а не 12)
'LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ResultFields = 5
'Вывод колонок с результатами
Results = Worksheets(2).Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count
re = Results + 1
Worksheets(2).Cells(1, 3) = "Группа"
Worksheets(2).Cells(1, 4) = "Тип"
Worksheets(2).Cells(1, 5) = "Модель"
Worksheets(2).Cells(1, 6) = "Проверки"
'Определение параметров прогрессбара
pi.StartNewAction 0, 95, "Porocess", , , o * 3
'Далее классификация по уровням
 
For j = 6 To o
 
pi.SubAction , "$index & $count" 'Вывод прогрессбара и его обновление     , "$time" + время
 Set a = Worksheets(2).Range("B1:B" & re).Find(What:=Worksheets(1).Cells(j, KeywordsC), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
    If Not a Is Nothing Then
    firstaddress = a.Address
        Do
        For i = 1 To ResultFields
        If IsEmpty(a.Offset(0, i)) And IsEmpty(a.Offset(0, i + 1)) Then
        a.Offset(0, i).Value = Worksheets(1).Cells(j, i + KeywordsC + 2)
        End If
        Next i
    Set a = Worksheets(2).Range("B1:B" & re).FindNext(a)
    Loop While Not a Is Nothing And a.Address <> firstaddress
    End If
Next j
 
For j = 6 To o
 
pi.SubAction , "$index & $count"
 Set a = Worksheets(2).Range("B1:B" & re).Find(What:=Worksheets(1).Cells(j, KeywordsC2), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
    If Not a Is Nothing Then
    firstaddress = a.Address
        Do
        For i = 1 To ResultFields
        a.Offset(0, i).Value = Worksheets(1).Cells(j, i + KeywordsC2 + 1)
        Next i
    Set a = Worksheets(2).Range("B1:B" & re).FindNext(a)
    Loop While Not a Is Nothing And a.Address <> firstaddress
    End If
Next j
 
For j = 6 To o
 
pi.SubAction , "$index & $count"
 Set a = Worksheets(2).Range("B1:B" & re).Find(What:=Worksheets(1).Cells(j, KeywordsC3), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
    If Not a Is Nothing Then
    firstaddress = a.Address
        Do
        For i = 1 To ResultFields
        a.Offset(0, i).Value = Worksheets(1).Cells(j, i + KeywordsC3)
        Next i
    Set a = Worksheets(2).Range("B1:B" & re).FindNext(a)
    Loop While Not a Is Nothing And a.Address <> firstaddress
    End If
Next j
 
pi.Hide 'Убираем прогрессбар
Worksheets(2).[B:B].SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'удаляем последнюю строку (т.к. она ошибочно заполняется)
 
End Sub
Sub Button7_Click()
 
Dim a As Range
Dim options As Long
Dim opt As Long
Dim o As Long
Dim Results As Long
Dim re As Long
Dim KeywordsC As Long
Dim KeywordsC2 As Long
Dim KeywordsC3 As Long
Dim ResultFields As Long
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single
    Dim pi As New ProgressIndicator
   
 
pi.Show "Progress"
KeywordsC = 2
KeywordsC2 = 3
KeywordsC3 = 4
options = Worksheets(1).Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
opt = options - 1
o = opt + 5
ResultFields = 5
Results = Worksheets(2).Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count
re = Results + 1
Worksheets(2).Cells(1, 3) = "Группа"
Worksheets(2).Cells(1, 4) = "Тип"
Worksheets(2).Cells(1, 5) = "Модель"
Worksheets(2).Cells(1, 6) = "Проверки"
pi.StartNewAction 0, 95, "Porocess", , , o
 
For j = 6 To o
 
pi.SubAction , "$index & $count"
 Set a = Worksheets(2).Range("B1:B" & re).Find(What:=Worksheets(1).Cells(j, KeywordsC), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
    If Not a Is Nothing Then
    firstaddress = a.Address
    Do
    For i = 1 To ResultFields
    If IsEmpty(a.Offset(0, i)) And IsEmpty(a.Offset(0, i + 1)) Then
    a.Offset(0, i).Value = Worksheets(1).Cells(j, i + KeywordsC + 2)
    End If
    Next i
                          
    Set a = Worksheets(2).Range("B1:B" & re).FindNext(a)
    Loop While Not a Is Nothing And a.Address <> firstaddress
    End If
  
Next j
 
pi.Hide
Worksheets(2).[B:B].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
End Sub
Sub Button8_Click()
 
Dim a As Range
Dim options As Long
Dim opt As Long
Dim o As Long
Dim Results As Long
Dim re As Long
Dim KeywordsC As Long
Dim KeywordsC2 As Long
Dim KeywordsC3 As Long
Dim ResultFields As Long
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single
    Dim pi As New ProgressIndicator
   
   
pi.Show "Progress"
KeywordsC = 2
KeywordsC2 = 3
KeywordsC3 = 4
options = Worksheets(1).Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
opt = options - 1
o = opt + 5
ResultFields = 5
Results = Worksheets(2).Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count
re = Results + 1
Worksheets(2).Cells(1, 3) = "Группа"
Worksheets(2).Cells(1, 4) = "Тип"
Worksheets(2).Cells(1, 5) = "Модель"
Worksheets(2).Cells(1, 6) = "Проверки"
pi.StartNewAction 0, 95, "Porocess", , , o
 
For j = 6 To o
 
pi.SubAction , "$index & $count"
 Set a = Worksheets(2).Range("B1:B" & re).Find(What:=Worksheets(1).Cells(j, KeywordsC2), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
    If Not a Is Nothing Then
    firstaddress = a.Address
    Do
    For i = 1 To ResultFields
    a.Offset(0, i).Value = Worksheets(1).Cells(j, i + KeywordsC2 + 1)
    Next i
                          
    Set a = Worksheets(2).Range("B1:B" & re).FindNext(a)
    Loop While Not a Is Nothing And a.Address <> firstaddress
    End If
  
Next j
 
pi.Hide
Worksheets(2).[B:B].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
End Sub
Sub Button9_Click()
 
Dim a As Range
Dim options As Long
Dim opt As Long
Dim o As Long
Dim Results As Long
Dim re As Long
Dim KeywordsC As Long
Dim KeywordsC2 As Long
Dim KeywordsC3 As Long
Dim ResultFields As Long
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single
    Dim pi As New ProgressIndicator
    
pi.Show "Progress"
KeywordsC = 2
KeywordsC2 = 3
KeywordsC3 = 4
options = Worksheets(1).Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
opt = options - 1
o = opt + 5
ResultFields = 5
Results = Worksheets(2).Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count
re = Results + 1
Worksheets(2).Cells(1, 3) = "Группа"
Worksheets(2).Cells(1, 4) = "Тип"
Worksheets(2).Cells(1, 5) = "Модель"
Worksheets(2).Cells(1, 6) = "Проверки"
pi.StartNewAction 0, 95, "Porocess", , , o
 
For j = 6 To o
pi.SubAction , "$index & $count"
 
Set a = Worksheets(2).Range("B1:B" & re).Find(What:=Worksheets(1).Cells(j, KeywordsC3), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
If Not a Is Nothing Then
    firstaddress = a.Address
    Do
    For i = 1 To ResultFields
    a.Offset(0, i).Value = Worksheets(1).Cells(j, i + KeywordsC3)
    Next i
                          
Set a = Worksheets(2).Range("B1:B" & re).FindNext(a)
Loop While Not a Is Nothing And a.Address <> firstaddress
End If
        
Next j
 
pi.Hide
Worksheets(2).[B:B].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
End Sub
Sub Formatias(ByVal n As Long)
   Cells(n).Interior.ColorIndex = 15: Cells(n).BorderAround xlContinuous 'Подвязка модуля для прогрессбара
End Sub

@kalbasiatka · 15.01.2015, 18:05

Каждый, посмотрев в код сразу поймёт, что должен делать этот макрос.
В файле покажите что и как на "небольшом объёме" информации

@Дмитрий111111 · 16.01.2015, 09:39 **[ТС]**

Задача макроса в том, чтобы классифицировать объекты по типу и моделям. Если запустить его в данном файле, он справится за считанные секунды, но если будет 100000 объектов, он будет справляться более 2х часов.

@KoGG · 16.01.2015, 11:26

Небольшое ускорение: удалил Прогрессбар и добавил процедуры ускорения для Application.
Существенно ускорить может работа с массивами и/или словарями, но это равносильно выкидыванию старого кода.

@Дмитрий111111 · 16.01.2015, 11:43 **[ТС]**

Значительно ускорило процесс, но работают только 2 кнопки) (1-го и 2-го порядка)
К сожалению я не могу доработать код, так как человек работающий с ним уволился.

@KoGG · 16.01.2015, 11:54

Уволился - не ценили работу. Берегите VBA программистов.

@Дмитрий111111 · 16.01.2015, 11:57 **[ТС]**

Благодарю, программирование не его профиль) он просто что то знал и мог в VBA

shanemac51 · 16.01.2015, 12:31

забыли закомментировать строку

Visual Basic

For j = 6 To o
 
''Pi.SubAction , "$index & $count" 'Âûâîä ïðîãðåññáàðà è åãî îáíîâëåíèå     , "$time" + âðåìÿ
 Set a = Worksheets(2).Range("B1:B" & re).Find(What:=Worksheets(1).Cells(j, KeywordsC), LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)

Новые блоги и статьи Все статьи Все блоги /
Использование кэша Laravel - полный гайд bytestream 18.02.2025 Кэширование - один из наиболее эффективных способов повышения производительности веб-приложений. В современном мире, где скорость загрузки страниц напрямую влияет на удержание пользователей и. . .	Создаем REST API в Laravel с аутентификацией через Passport bytestream 18.02.2025 Разработка современных веб-приложений все чаще требует создания надежного и хорошо структурированного API. REST API стал стандартом де-факто для построения взаимодействия между клиентской и серверной. . .	Пайплайны в Laravel - полный гайд bytestream 18.02.2025 Разработка современных веб-приложений часто требует обработки сложных процессов, состоящих из множества последовательных шагов. Например, при создании системы комментариев может потребоваться. . .	Как правильно использовать @required в Symfony bytestream 18.02.2025 При разработке приложений на Symfony мы часто сталкиваемся с необходимостью внедрения зависимостей. Фреймворк предоставляет несколько способов управления этим процессом, и одним из таких инструментов. . .	Система безопасности в Laravel: возможности и примеры Wired 18.02.2025 Каждый день появляются новые виды атак и уязвимостей, которые могут поставить под угрозу конфиденциальные данные пользователей и функционирование всей системы. В этом контексте выбор надежного. . .
Давайте сравним Django и Laravel Wired 18.02.2025 Django и Laravel - два мощных инструмента, которые часто сравнивают между собой. Оба фреймворка предлагают разработчикам богатый набор возможностей для создания масштабируемых веб-приложений, но. . .	Laravel или React - что лучше? Wired 18.02.2025 В разработке веб выбор правильного инструмента часто определяет успех всего проекта. Особенно интересным представляется сравнение Laravel и React - двух популярных технологий, которые часто. . .	Laravel 11: новые возможности, гайд по обновлению Wired 18.02.2025 Laravel 11 - это новая масштабная версия одного из самых популярных PHP-фреймворков, выпущенная в марте 2024 года. Эта версия продолжает традицию внедрения передовых технологий и методологий. . .	Миграции в Laravel Wired 18.02.2025 Разработка веб-приложений на Laravel неразрывно связана с управлением структурой базы данных. При работе над проектом часто возникает необходимость вносить изменения в схему базы данных - добавлять. . .	Аутентификация в Laravel Wired 18.02.2025 В современном мире веб-разработки безопасность пользовательских данных становится критически важным аспектом любого приложения. Laravel, как один из самых популярных PHP-фреймворков, предоставляет. . .

@kalbasiatka 416 / 263 / 83 Регистрация: 27.10.2012 Сообщений: 861
	15.01.2015, 18:05	2
	Каждый, посмотрев в код сразу поймёт, что должен делать этот макрос. В файле покажите что и как на "небольшом объёме" информации 0

@Дмитрий111111 0 / 0 / 0 Регистрация: 15.01.2015 Сообщений: 4
	16.01.2015, 11:43 [ТС]	5
	Значительно ускорило процесс, но работают только 2 кнопки) (1-го и 2-го порядка) К сожалению я не могу доработать код, так как человек работающий с ним уволился. Миниатюры 0

@Дмитрий111111 0 / 0 / 0 Регистрация: 15.01.2015 Сообщений: 4
	16.01.2015, 11:57 [ТС]	7
	Благодарю, программирование не его профиль) он просто что то знал и мог в VBA 0

	15.01.2015, 16:18

	16.01.2015, 12:31