Оптимизация простого макроса поиска и выборки

@РоманВалерьевич · Регистрация: 01.08.2013

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

Здравствуйте уважаемые форумчане.

Помогите мне пожалуйста оптимизировать макрос поиска. Не кидайте тапками, это мой второй в жизни макрос после "Hello World"

. Макрос выбирает с общего клиент-банка(excel), только строки платежей клиентов одного филиала, ориентируясь на столбец в клиент-банке с кодом предприятия (в качестве ID), сравнивает с таблицей истинности на другом листе, И добавляет на третий лист отсортированный список. Макрос работает, но, очень медленно.

PureBasic
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
Dim BDcount As Integer
Dim BankCount As Integer
Dim KHMRowsCount As Integer
Dim P3 As Integer
Dim P4 As Integer
Dim BDcurrentCell As Currency
Dim BankCurrentCell As Currency
Dim Result As Currency
 
    Sheets("БД_полезешь-руки повыдерну").Select
BDcount = ActiveSheet.UsedRange.Rows.Count
    Sheets("Банк").Select
BankCount = ActiveSheet.UsedRange.Rows.Count - 1
    Rows("1:2").Copy
    Sheets("Банк Хмельницкий").Select
    Rows("1:2").Select
    ActiveSheet.Paste
    P4 = 1
For j = 1 To BDcount Step 1
    P3 = 3
    For i = 1 To BankCount Step 1
    Sheets("БД_полезешь-руки повыдерну").Select
    BDcurrentCell = Cells(P4, 2)
    Sheets("Банк").Select
    BankCurrentCell = Cells(P3, 23)
        
        If BDcurrentCell = BankCurrentCell Then
            Rows(P3).Copy
            Sheets("Банк Хмельницкий").Select
            KHMRowsCount = ActiveSheet.UsedRange.Rows.Count + 1
            Rows(KHMRowsCount).Select
            ActiveSheet.Paste
        End If
      P3 = P3 + 1
    Next i
  P4 = P4 + 1
Next j
   
    
End Sub

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

подкрепил файлик для наглядности.

Помогите пожалуйста, начинающему коллеге.

@Hugo121 · 02.08.2013, 17:51

Не по теме:

Наверняка эти ключи по офису на бумажках раскиданы...

@РоманВалерьевич · 02.08.2013, 18:01 **[ТС]**

Сообщение от Hugo121

Вот тут и должно бы подсуетиться начальство - всех акул уволить, их работу взвалить на Вас. За ту же зарплату

Так что лучше молчите

Добавлено через 2 минуты
Экономия в деньгах, отсутствие ошибок...

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

@Hugo121 · 02.08.2013, 18:11

Да, тут нужно тонко подходить...
С одной строны, так может быть можно продвинуться, увеличить статус/зарплату.
А с другой стороны (особенно если двигаться некуда, а начальство жадное) - могут навалить ещё работы на освободившееся время, а техподдержка всего этого творчества тоже будет на Вас.
Например написали десяток скриптов (да хоть и 5, но ключевых) - если раз в месяц что-то где-то меняется, значит раз в месяц будете бесплатно эти скрипты править

Добавлено через 3 минуты
Особенно классно, когда эти скрипты облегчают работу не Вам, а кому-то с зарплатой чуть повыше... Который сам в этом вообще ни в зуб...

@РоманВалерьевич · 02.08.2013, 18:21 **[ТС]**

Ув. Hugo121 с моим уровнем владения VBA, мне тяжеловато сопоставить мой первичный макрос, с Вашим апдейтом, и провести аналогии, извлечь для себя новые приёмы. В Вашем варианте для меня присуцтвуют много неясных моментов. Покоментируйте пожалуйста подробнее Ваш вариант.

Просто вкратце что каждая строка делает, мне это здорово поможет.

@Hugo121 · 02.08.2013, 22:32

Позже, работа заканчивается.
Но фильтра там нет - не люблю фильтр...

Добавлено через 4 часа 3 минуты
Вот, всё расписал, кое-что добавил (форматы):

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
'заставляет объявлять все переменные -
'меньше шансов ошибиться с всякими а и a!
Option Explicit
 
Sub tt()
'объявление переменных - и никаких Integer, особенно для счётчика строк!
    Dim a(), i As Long, ii As Long, ind As Long
 
    'очищаем возможно "грязный" лист (и от форматов тоже)
    Sheets("Банк Хмельницкий").UsedRange.Clear
 
    'копируем строку-шапку со всеми форматами
    Sheets("Банк").Rows(2).Copy Sheets("Банк Хмельницкий").[a1]
 
    'берёи в массив номера-критерии (только второй столбец)
    a = Sheets("БД_полезешь-руки повыдерну").[a1].CurrentRegion.Columns(2).Value
 
    'работаем с словарём - без объектной переменной!
    With CreateObject("Scripting.Dictionary")
        'наполняем словарь номерами (в item пустышку типа long - говорят так быстрее)
        'без заполнения Item нельзя - хотя тут оно не функционально (поэтому пустышка)
        For i = 1 To UBound(a): .Item(a(i, 1)) = 0&: Next
 
        'берёи в массив все исходные данные
        a = Sheets("Банк").[a1].CurrentRegion.Value
 
        'создаём пустой массив для отобранного - размером с исходный
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
        'цикл по исходным данным
        For i = 1 To UBound(a)
            'если в словаре есть критерий из текущей строки массива
            If .exists(a(i, 23)) Then
                'увеличиваем индекс
                ind = ind + 1
                'копируем текущую строку из массива в массив
                'цикл по ширине строки
                For ii = 1 To UBound(b, 2)
                    b(ind, ii) = a(i, ii)
                Next
            End If
        Next
 
    End With
 
    'если есть отобранное!
    If ind > 0 Then
        'работа с листом "Банк Хмельницкий"
        With Sheets("Банк Хмельницкий")
            'задаём текстовый формат ячейкам (точно под размер выгрузки)
            'тут можно чуть пооптимизировать, но так понятнее
            .[a2].Resize(ind, 1).NumberFormat = "@"
            .[f2].Resize(ind, 2).NumberFormat = "@"
            .[l2].Resize(ind, 4).NumberFormat = "@"
            .[r2].Resize(ind, 8).NumberFormat = "@"
            .[aa2].Resize(ind, 1).NumberFormat = "@"
            'и не только текстовый
            .[h2].Resize(ind, 4).NumberFormat = "#*###*##0.00"
            'выгружаем массив на лист
            .[a2].Resize(ind, 30) = b
        End With
    End If
End Sub

@РоманВалерьевич · 03.08.2013, 15:31 **[ТС]**

Сообщение от Hugo121

Позже, работа заканчивается.
Но фильтра там нет - не люблю фильтр...

Добавлено через 4 часа 3 минуты
Вот, всё расписал, кое-что добавил (форматы):

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
'заставляет объявлять все переменные -
'меньше шансов ошибиться с всякими а и a!
Option Explicit
 
Sub tt()
'объявление переменных - и никаких Integer, особенно для счётчика строк!
    Dim a(), i As Long, ii As Long, ind As Long
 
    'очищаем возможно "грязный" лист (и от форматов тоже)
    Sheets("Банк Хмельницкий").UsedRange.Clear
 
    'копируем строку-шапку со всеми форматами
    Sheets("Банк").Rows(2).Copy Sheets("Банк Хмельницкий").[a1]
 
    'берёи в массив номера-критерии (только второй столбец)
    a = Sheets("БД_полезешь-руки повыдерну").[a1].CurrentRegion.Columns(2).Value
 
    'работаем с словарём - без объектной переменной!
    With CreateObject("Scripting.Dictionary")
        'наполняем словарь номерами (в item пустышку типа long - говорят так быстрее)
        'без заполнения Item нельзя - хотя тут оно не функционально (поэтому пустышка)
        For i = 1 To UBound(a): .Item(a(i, 1)) = 0&: Next
 
        'берёи в массив все исходные данные
        a = Sheets("Банк").[a1].CurrentRegion.Value
 
        'создаём пустой массив для отобранного - размером с исходный
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
        'цикл по исходным данным
        For i = 1 To UBound(a)
            'если в словаре есть критерий из текущей строки массива
            If .exists(a(i, 23)) Then
                'увеличиваем индекс
                ind = ind + 1
                'копируем текущую строку из массива в массив
                'цикл по ширине строки
                For ii = 1 To UBound(b, 2)
                    b(ind, ii) = a(i, ii)
                Next
            End If
        Next
 
    End With
 
    'если есть отобранное!
    If ind > 0 Then
        'работа с листом "Банк Хмельницкий"
        With Sheets("Банк Хмельницкий")
            'задаём текстовый формат ячейкам (точно под размер выгрузки)
            'тут можно чуть пооптимизировать, но так понятнее
            .[a2].Resize(ind, 1).NumberFormat = "@"
            .[f2].Resize(ind, 2).NumberFormat = "@"
            .[l2].Resize(ind, 4).NumberFormat = "@"
            .[r2].Resize(ind, 8).NumberFormat = "@"
            .[aa2].Resize(ind, 1).NumberFormat = "@"
            'и не только текстовый
            .[h2].Resize(ind, 4).NumberFormat = "#*###*##0.00"
            'выгружаем массив на лист
            .[a2].Resize(ind, 30) = b
        End With
    End If
End Sub

Hugo12 примирите мою искреннюю благодарность

, скрипт прямо формы обретает, чувствую себя всемогущим программистом, теперь вижу что почитать нужно

@Hugo121 · 03.08.2013, 15:49

Заметил неточность - вместо

Visual Basic
1
.[a2].Resize(ind, 30) = b

нужно

Visual Basic
1
.[a2].Resize(ind, UBound(b, 2)) = b

Это если вдруг столбцов будет не 30. Если будет меньше - то тут на листе будут н/д, если больше - то хвост недовыгрузит.
А так всё под размер массива - выше я уже исправил, тут забыл

@РоманВалерьевич · 05.08.2013, 15:43 **[ТС]**

Сообщение от Hugo121

Заметил неточность - вместо

Visual Basic
1
.[a2].Resize(ind, 30) = b

нужно

Visual Basic
1
.[a2].Resize(ind, UBound(b, 2)) = b

Это если вдруг столбцов будет не 30. Если будет меньше - то тут на листе будут н/д, если больше - то хвост недовыгрузит.
А так всё под размер массива - выше я уже исправил, тут забыл

Ок, Спасибо. Количество столбцов - константа.

@РоманВалерьевич · 15.08.2013, 14:15 **[ТС]**

Hugo121 поработав над кодом, я слегка его адаптировал под моих пользователей, но есть один момент который мне не поддался. Не получилось что-бы на лист "Банк Хмельницкий" название организации импортировалось не от колонки "V"(имя организации) в листе Банк, а с таблицы истинности(БД_полезешь-руки повыдерну) первая колонка.

@Hugo121 · 15.08.2013, 16:09

Это чуть сложнее - это название в той версии кода вообще не фигурировало.
Значит делаем так - массив a() чуть пошире, чтоб и название было, запоминаем в словаре не только код, но и название (в Item), после заполнения в цикле строки массива заменяем уже заполненное название названием из словаря.
Можно конечно бить цикл на две части -
For ii = 1 To 16
и
For ii = 18 To UBound(b, 2)
но проще
b(ind, 17) = .Item(a(i, 23))

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
'заставляет объявлять все переменные -
'меньше шансов ошибиться с всякими а и a!
Option Explicit
 
Sub tt()
'объявление переменных - и никаких Integer, особенно для счётчика строк!
    Dim a(), i As Long, ii As Long, ind As Long
 
    'очищаем возможно "грязный" лист (и от форматов тоже)
    Sheets("Банк Хмельницкий").UsedRange.Clear
 
    'копируем строку-шапку со всеми форматами
    Sheets("Банк").Rows(2).Copy Sheets("Банк Хмельницкий").[a1]
 
    'берёи в массив номера-критерии и названия
    a = Sheets("БД_полезешь-руки повыдерну").[a1].CurrentRegion.Value
 
    'работаем с словарём - без объектной переменной!
    With CreateObject("Scripting.Dictionary")
        'наполняем словарь номерами (в item название)
        For i = 1 To UBound(a): .Item(a(i, 2)) = a(i, 1): Next
 
        'берёи в массив все исходные данные
        a = Sheets("Банк").[a1].CurrentRegion.Value
 
        'создаём пустой массив для отобранного - размером с исходный
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
        'цикл по исходным данным
        For i = 1 To UBound(a)
            'если в словаре есть критерий из текущей строки массива
            If .exists(a(i, 23)) Then
                'увеличиваем индекс
                ind = ind + 1
                'копируем текущую строку из массива в массив
                'цикл по ширине строки
                For ii = 1 To UBound(b, 2)
                    b(ind, ii) = a(i, ii)
                Next
                b(ind, 17) = .Item(a(i, 23))
            End If
        Next
 
    End With
 
    'если есть отобранное!
    If ind > 0 Then
        'работа с листом "Банк Хмельницкий"
        With Sheets("Банк Хмельницкий")
            'задаём текстовый формат ячейкам (точно под размер выгрузки)
            'тут можно чуть пооптимизировать, но так понятнее
            .[a2].Resize(ind, 1).NumberFormat = "@"
            .[f2].Resize(ind, 2).NumberFormat = "@"
            .[l2].Resize(ind, 4).NumberFormat = "@"
            .[r2].Resize(ind, 8).NumberFormat = "@"
            .[aa2].Resize(ind, 1).NumberFormat = "@"
            'и не только текстовый
            .[h2].Resize(ind, 4).NumberFormat = "# ### ##0.00"
            'выгружаем массив на лист
            .[a2].Resize(ind, 30) = b
        End With
    End If
End Sub

Добавлено через 1 час 29 минут
Там какая-то чехарда с форматами - сперва я закопипастил
.[h2].Resize(ind, 4).NumberFormat = "#*###*##0.00"
теперь у меня это генерит мусор, сделал так:
.[h2].Resize(ind, 4).NumberFormat = "# ### ##0.00"
Может потому, что звёздочки были в русском 2007 Экселе, а пробелы нужны в английском 2003?
Некая лёгкая несовместимость продуктов...
Ну это в данном случае мелочь, исправьте по вкусу

@РоманВалерьевич · 15.08.2013, 16:52 **[ТС]**

Ах ну конечно же, как я был близок, я эту строку не поменял,

Visual Basic
1
For i = 1 To UBound(a): .Item(a(i, 2)) = a(i, 1): Next

словари ещё не освоил.

А на счёт

Visual Basic
1
.[h2].Resize(ind, 4).NumberFormat = "#*###*##0.00"

у меня циферки таки решеточками писались я заменил на

Visual Basic
1
.[h2].Resize(ind, 4).NumberFormat = "0.00"

Неудобно было когда всё слитно перед точкой, но с пробелами работает как надо, исправил, Спасибо за помощь.
П.С. Я использую Excel 2003 SP3. русский

@Hugo121 · 15.08.2013, 17:04

Я эти форматы дома записывал рекордером - включил, посмотрел что там у Вас за формат, симитировал изменение, остановил запись.
Откуда взялись звёздочки - не знаю, может дома так было, может форум добавил...

Новые блоги и статьи Все статьи Все блоги /
Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого 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) активировать флаг. . .	Архитектура биовида Стива в Майнкрафте: Зачем бонобо кубический каннибализм anaschu 30.08.2026 Кубический Вагинокапитализм в Minecraft: Математический инвариант ОДУ и рок Стивов-бонобо Главная задача разработанной «Модели Всего» — наглядно продемонстрировать наличие системной «судьбы». . .	Оттачиваю умение писать js программы. russiannick 30.08.2026 Проектом выходного дня стало написание Книги шифров Виженера. Итогом стала версия 200, синий туман. Синий туман назван так, потому что замораживает текст под собой. Нажатие синих кнопок управляют. . .

@Hugo121
	02.08.2013, 17:51
	Не по теме: Наверняка эти ключи по офису на бумажках раскиданы... 1

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	02.08.2013, 18:11
	Да, тут нужно тонко подходить... С одной строны, так может быть можно продвинуться, увеличить статус/зарплату. А с другой стороны (особенно если двигаться некуда, а начальство жадное) - могут навалить ещё работы на освободившееся время, а техподдержка всего этого творчества тоже будет на Вас. Например написали десяток скриптов (да хоть и 5, но ключевых) - если раз в месяц что-то где-то меняется, значит раз в месяц будете бесплатно эти скрипты править Добавлено через 3 минуты Особенно классно, когда эти скрипты облегчают работу не Вам, а кому-то с зарплатой чуть повыше... Который сам в этом вообще ни в зуб... 1

@РоманВалерьевич 0 / 0 / 0 Регистрация: 01.08.2013 Сообщений: 15
	02.08.2013, 18:21 [ТС]
	Ув. Hugo121 с моим уровнем владения VBA, мне тяжеловато сопоставить мой первичный макрос, с Вашим апдейтом, и провести аналогии, извлечь для себя новые приёмы. В Вашем варианте для меня присуцтвуют много неясных моментов. Покоментируйте пожалуйста подробнее Ваш вариант. Просто вкратце что каждая строка делает, мне это здорово поможет. 0

@РоманВалерьевич 0 / 0 / 0 Регистрация: 01.08.2013 Сообщений: 15
	15.08.2013, 14:15 [ТС]
	Hugo121 поработав над кодом, я слегка его адаптировал под моих пользователей, но есть один момент который мне не поддался. Не получилось что-бы на лист "Банк Хмельницкий" название организации импортировалось не от колонки "V"(имя организации) в листе Банк, а с таблицы истинности(БД_полезешь-руки повыдерну) первая колонка. 0

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	15.08.2013, 17:04
	Я эти форматы дома записывал рекордером - включил, посмотрел что там у Вас за формат, симитировал изменение, остановил запись. Откуда взялись звёздочки - не знаю, может дома так было, может форум добавил... 1

Оптимизация простого макроса поиска и выборки

Решение