Имя пользователя:
Пароль:  
Помощь | Регистрация | Забыли пароль?  | Правила  

Компьютерный форум OSzone.net » Программирование, базы данных и автоматизация действий » Программирование и базы данных » VBA - Ускорить работу макроса

Ответить
Настройки темы
VBA - Ускорить работу макроса

Аватара для blackeangel

Старожил


Сообщения: 329
Благодарности: 3

Профиль | Отправить PM | Цитировать


Как ускорить работу скрипта?
Код: Выделить весь код
Sub test()
    Dim arr1()
    Application.ScreenUpdating = False
    'range и массив рабочей книги
    ncolumn = Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole).Column
    Columns(ncolumn + 1).Insert 'вставляем столбец справа
    Cells(1, ncolumn + 1).Value = "Карточки" 'вставляем заголовок столбца
    m = ActiveSheet.Cells(Rows.Count, ncolumn).End(xlUp).Row
    Set rn = ActiveSheet.Cells(2, ncolumn).Resize(m, 2)
    arr2 = rn.Value
    Set conn = New ADODB.Connection     'Создание соединения
    conn.ConnectionString = "Provider=SQLOLEDB.1;Password=132132;Persist Security Info=True;User ID=User;Initial Catalog=dbScanKD;Data Source=SQL05" 'Строка подключения
    conn.Open   'Открытие соединения
    Set rst = New ADODB.Recordset ' Создание объекта Recordset.
    rst.ActiveConnection = conn ' Подключение этого объекта к ранее открытому каналу связи.
    Ask = "SELECT DISTINCT [Oboznach] FROM [dbScanKD].[dbo].[vwScanKD] Where Not ([Oboznach] Like '%СБ'or [Oboznach] Like '%ТУ' or [Oboznach] Like '%ИМ' or [Oboznach] Like '%ДИ' or [Oboznach] Like '%РР' or [Oboznach] Like '%РИ' or [Oboznach] Like '%УД' or [Oboznach] Like '%ЛУ' or [Oboznach] Like '%ТБ' or [Oboznach] Like '%Э3' or [Oboznach] Like '%ПЭ3' or [Oboznach] Like '%Д7' or [Oboznach] Like '%К3' or [Oboznach] Like '%Д4' or [Oboznach] Like '%ДП' or [Oboznach] Like '%РИ' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%ПГ4' or [Oboznach] Like '%Г4' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2')"
    rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic  ' выполняем запрос.
    arr1 = rst.GetRows 'закидываем в массив
    conn.Close 'закрываем соединение
    arr1 = TransposeDim(arr1) 'переворачиваем массив из строк в столбец через функцию TransposeDim с сайта майкрософт
	For i = LBound(arr1) To UBound(arr1)
        For j = LBound(arr2) To UBound(arr2)
            If Len(arr2(j, 1)) > 0 Then
                If InStr(1, arr1(i, 0), "СБ") > 0 Then
                    If InStr(arr2(j, 1), "-") > 0 Then
                        m = Left(arr2(j, 1), InStr(1, arr2(j, 1), "-") - 1) + "СБ"
                        If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        Else
                            If InStr(1, m, arr1(i, 0), vbTextCompare) > 0 Then
                                If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                    arr2(j, 2) = arr1(i, 0)
                                Else
                                    arr2(j, 2) = "нет страниц"
                                End If
                            End If
                        End If
                    Else
                        If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        End If
                    End If
                Else
                    If arr2(j, 2) = Empty Then
                        If InStr(1, arr2(j, 1), arr1(i, 0), vbTextCompare) > 0 Then
                            For k = 1 To UBound(massoboz)
                                If InStr(arr2(j, 1), massoboz(k, 1)) > 0 Then
                                    arr2(j, 2) = "нет сборочного"
                                    Exit For
                                Else
                                    If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                        arr2(j, 2) = arr1(i, 0)
                                    Else
                                        arr2(j, 2) = "нет страниц"
                                    End If
                                End If
                            Next k
                        End If
                    End If
                End If
            End If
        Next j
    Next i
    ActiveSheet.Cells(2, ncolumn).Resize(UBound(arr2), UBound(arr2, 2)) = arr2'вываливаем на лист
    Application.ScreenUpdating = True
End Sub
А то 2 массива: один 69тыс, второй 500тыс сравнивались друг с другом 6 часов, что мягко говоря ни в какие ворота не лезет. Рассмотрю любые варианты.

-------
Забудем боль, забудем страх -
И только ветер в парусах!


Отправлено: 16:25, 30-11-2017

 

Аватара для blackeangel

Старожил


Сообщения: 329
Благодарности: 3

Профиль | Отправить PM | Цитировать


Вложения
Тип файла: zip Пеример.zip
(4.4 Kb, 1 просмотров)

Если интересно, вот пример того что надо получить с исходными данными как раз те 6 номеров которые отработали за 10 сек.

-------
Забудем боль, забудем страх -
И только ветер в парусах!


Отправлено: 12:46, 01-12-2017 | #11



Для отключения данного рекламного блока вам необходимо зарегистрироваться или войти с учетной записью социальной сети.

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


Аватара для blackeangel

Старожил


Сообщения: 329
Благодарности: 3

Профиль | Отправить PM | Цитировать


Iska, есть вот такой код, по словам автора он, в какой то степени решает мою задачу. Но объяснять код отказался. Может вы что скажете дельного?
Код: Выделить весь код
Option Explicit
'
'Код для Лист1
'
Dim cl As New Collection
 
Private Sub CommandButton2_Click()
    '
    'Поиск приближенных совпадений
    '
    Dim i&, j&, ii&, jj&, s$, try&, v, CurR&, CurC&
    Dim yes&
    On Error Resume Next 'Включаем игнор ошибок
    Set cl = New Collection 'Инициализируем коллекцию
    CurR = 14 'Сюда будем писать результаты начиная с 14-й строки
    
    With Sheets("лист3") 'Заполняем коллекцию для искомых данных
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear: cl.Add .Cells(i, j), s
                If Err = 0 Then Exit For 'Выход если ключ не занят
            Next
        Next j, i
    End With
    
    With Sheets("лист2")
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            yes = 0
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear
                v = cl(s)
                If Err Then Exit For 'Эта ошибка возникает если совпадений более нет
                yes = 1
                With Sheets("лист1")
                    CurC = (try - 3) * 3
                    .Cells(CurR, 1 + CurC).Value = s
                    .Cells(CurR, 2 + CurC).Value = v
                End With
            Next
            CurR = CurR + yes
        Next j, i
    End With
    
 
End Sub
 
Sub RWord(Range As Range)
    '
    'Случайное слово с точкой и цифрой
    '
    Dim i&, j&, s$
    s = Space(20)
    For i = 1 To 3
        Mid$(s, i, 1) = Chr(97 + Fix(Rnd * 26))
    Next: Mid$(s, i, 1) = "."
    For i = i + 1 To i + 3 + Fix(Rnd * 3)
        Mid$(s, i, 1) = Fix(Rnd * 10)
    Next
    Range.Value = RTrim$(s)
End Sub
 
Private Sub CommandButton1_Click()
    '
    'Создание двух таблиц со случайными значениями
    '
    Dim i&, j&
    With Sheets("лист2")
        .Cells.ClearContents
        For i = 1 To 100: For j = 1 To 10
            RWord .Cells(i, j)
        Next j, i
    End With
    With Sheets("лист3")
        .Cells.ClearContents
        For i = 1 To 200: For j = 1 To 20
            RWord .Cells(i, j)
        Next j, i
    End With
End Sub
 
 
Private Sub CommandButton3_Click()
    With Sheets("лист1")
        .Rows("14:" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    End With
End Sub

-------
Забудем боль, забудем страх -
И только ветер в парусах!


Отправлено: 18:06, 01-12-2017 | #12


Аватара для blackeangel

Старожил


Сообщения: 329
Благодарности: 3

Профиль | Отправить PM | Цитировать


Вложения
Тип файла: rar Копия Книга1.rar
(54.0 Kb, 1 просмотров)

Вот он же, только в книге.

-------
Забудем боль, забудем страх -
И только ветер в парусах!


Отправлено: 18:07, 01-12-2017 | #13


Ветеран


Сообщения: 27449
Благодарности: 8086

Профиль | Отправить PM | Цитировать


Цитата blackeangel:
Iska, есть вот такой код, по словам автора он, в какой то степени решает мою задачу. Но объяснять код отказался. Может вы что скажете дельного? »
Ничего не скажу. Ибо не могу по Вашему коду понять Ваш алгоритм и исходную задачу. Равно и то, как приведённый теперь код соответствует Вашему алгоритму. Если автор так утверждает, что ж — берите, пробуйте.

Отправлено: 18:26, 01-12-2017 | #14


Аватара для blackeangel

Старожил


Сообщения: 329
Благодарности: 3

Профиль | Отправить PM | Цитировать


Цитата Iska:
Если автор так утверждает, что ж — берите, пробуйте. »
Если б он подходил, я бы взял. Но его надо допил ватт очень долго и усердно. А тк я в коллекциях не в зуб ногой, а вы соображаете.
А свой код методом переборов массива могу расписать от и до, чтоб вам понятно было.

-------
Забудем боль, забудем страх -
И только ветер в парусах!


Отправлено: 18:38, 01-12-2017 | #15


Ветеран


Сообщения: 27449
Благодарности: 8086

Профиль | Отправить PM | Цитировать


Цитата blackeangel:
А тк я в коллекциях не в зуб ногой, а вы соображаете. »
В данном случае Collection из VBA немного отличается от Dictionary из VBScript в сторону упрощения, но каких-то сложностей там нет: откройте редактор VBA, нажмите F2, наберите в поиске «Collection», нажмите «Enter», выберете класс Collection из библиотеки VBA, в правом окне увидите Members of 'Collection' — все члены класса, выделив конкретный член класса — внизу увидите его описание.

Цитата blackeangel:
А свой код методом переборов массива могу расписать от и до, чтоб вам понятно было. »
Навряд ли выйдет, думаю. Мы ж уже несколько раз пробовали, но не срасталось.

Отправлено: 18:52, 01-12-2017 | #16


Аватара для blackeangel

Старожил


Сообщения: 329
Благодарности: 3

Профиль | Отправить PM | Цитировать


Iska,
Цитата Iska:
исходную задачу. »
Заключается в том, что: есть список, есть база. Надо узнать есть ли записи из списка в базе.

А теперь как работает мой код.
Загружаем в 2 массива(arr1 из базы, arr2 c листа).
Берём arr1 и проверяем каждый номер по тому по arr2. Причем проверяем входимость.
Если есть в элементе arr1 "СБ" тогда проверяем, есть ли в текущем элементе arr2 символ "-", Если есть, то в переменную m записываем все что до черточки., проверяем есть ли текущее arr1 + "СБ", дальше сверяем 2 столбца в arr1, и если они равны, то тогда в arr2 пишем значение arr1, если нет, то пишем что "нет страниц" вот этот кусок кода
Код: Выделить весь код
For i = LBound(arr1) To UBound(arr1)
        For j = LBound(arr2) To UBound(arr2)
            If Len(arr2(j, 1)) > 0 Then
                If InStr(1, arr1(i, 0), "СБ") > 0 Then
                    If InStr(arr2(j, 1), "-") > 0 Then
                        m = Left(arr2(j, 1), InStr(1, arr2(j, 1), "-") - 1) + "СБ"
                        If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        Else
Едем дальше.
Проверяем есть ли m в текущем arr1, если есть, то сравниваем значения 2х столбцов из arr1, если нет, то пишем в arr2 "нет страниц".
Код: Выделить весь код
If InStr(1, m, arr1(i, 0), vbTextCompare) > 0 Then
                                If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                    arr2(j, 2) = arr1(i, 0)
                                Else
                                    arr2(j, 2) = "нет страниц"
                                End If
                            End If
                        End If
Если нет черточки, то тогда к arr2 приляпываем "СБ" и и опять сравниваем столбцы.
Код: Выделить весь код
If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
                            If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                arr2(j, 2) = arr1(i, 0)
                            Else
                                arr2(j, 2) = "нет страниц"
                            End If
                        End If
                    End If
Если в arr1 не содержится "СБ", тогда берём и крутим 3й массив в котором есть отметка о типе данной и проверяем есть ли совпадения
Код: Выделить весь код
If arr2(j, 2) = Empty Then
                        If InStr(1, arr2(j, 1), arr1(i, 0), vbTextCompare) > 0 Then
                            For k = 1 To UBound(massoboz)
                                If InStr(arr2(j, 1), massoboz(k, 1)) > 0 Then
                                    arr2(j, 2) = "нет сборочного"
                                    Exit For
                                Else
                                    If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
                                        arr2(j, 2) = arr1(i, 0)
                                    Else
                                        arr2(j, 2) = "нет страниц"
                                    End If
                                End If
                            Next k
                        End If
                    End If

-------
Забудем боль, забудем страх -
И только ветер в парусах!


Отправлено: 19:36, 01-12-2017 | #17


Ветеран


Сообщения: 27449
Благодарности: 8086

Профиль | Отправить PM | Цитировать


Цитата blackeangel:
Заключается в том, что: есть список, есть база. Надо узнать есть ли записи из списка в базе. »
Тогда бы было всё очень просто сделать одним запросом. Но у Вас-то не так.

Всё, что Вы описываете, понятно из самого кода. Я не об этом. Я о том, что на всё описанное куча вопросов «Зачем?», «Зачем так?» и «Почему именно так, а не иначе?». Понимаете — о чём я?

На всякий случай: в VB/VBA/VBScript есть одна такая хорошая функция Filter. Не знаю, поможет ли она Вам как-то, но посмотрите на примеры её использования.

Отправлено: 19:50, 01-12-2017 | #18

y-- y-- вне форума

Старожил


Сообщения: 231
Благодарности: 62

Профиль | Отправить PM | Цитировать


blackeangel,
Подробнее - либо через DTS либо напрямую через источник данных в ODBC - разово или на постоянной основе организовать перекачку данных в таблицу SQL.
Именно в таблицу - так как дергать по одной записи тож на тож выйдет - то есть медленно.
В процессе переброски не забыть об обрезании пробелов справа и слева для текстовых значений(alltrim()) и приведении всех остальных данных к правильному типу(с полями типа дата может изрядный геморой быть - в общей ситуации може даже проще затягивать как текст и считывать по формату).
А дальше элементарный селект...
Если на постоянной основе делать то надо вначале создать таблицу нужной структуры и единовременно залить все данные, на дальнейшее лучше реализовать что-то типа триггера на доливку/обновление/удаление разности - я-ля реплицировать.
Примеров в сети по работе с DTS - море, да и маны достаточно подробные

-------
Ты это - заходи если что...


Отправлено: 20:20, 01-12-2017 | #19


Ветеран


Сообщения: 27449
Благодарности: 8086

Профиль | Отправить PM | Цитировать


y--, SELECT можно и для Рабочего листа Excel выполнять, не в том дело.

Отправлено: 20:23, 01-12-2017 | #20



Компьютерный форум OSzone.net » Программирование, базы данных и автоматизация действий » Программирование и базы данных » VBA - Ускорить работу макроса

Участник сейчас на форуме Участник сейчас на форуме Участник вне форума Участник вне форума Автор темы Автор темы Шапка темы Сообщение прикреплено

Похожие темы
Название темы Автор Информация о форуме Ответов Последнее сообщение
CMD/BAT - [решено] Возможно ли ускорить работу Findstr? Darkar25 Скриптовые языки администрирования Windows 2 04-09-2017 23:42
Блог - Как ускорить работу в системе с помощью избранного Vadikan Microsoft Windows 7 0 10-01-2011 10:30
Как ускорить работу FreeBSD? BSDmaster Общий по FreeBSD 9 15-09-2007 23:28
Dial up. Как ускорить работу модема? grob40 Сетевые технологии 6 12-12-2006 14:56
Как ускорить загрузку и работу Windows? TVI Microsoft Windows 2000/XP 32 03-06-2004 16:29




 
Переход