Ускорить работу макроса

[blackeangel]

Как ускорить работу скрипта?

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 часов, что мягко говоря ни в какие ворота не лезет. Рассмотрю любые варианты.

[Iska]

Вы проверяли, куда именно уходит время, на какие строки кода? Тупо расставить вывод времени и места в коде в текстовый файл и смотреть?

[blackeangel]

Iska, здравствуйте) рад видеть вас) в общем загрузка в массив из запроса примерно 25-30 сек (это те самые 500тыс строк) это знаю точно.
По количеству комбинаций знаю что 34,5 миллиарда. Хотя это не так важно.
Завтра посмотрю на время.
Придется воспользоваться коллекциями или словарём, если проблема в переборе 2х массивов?

[Iska]

Придется воспользоваться коллекциями или словарём, если проблема в переборе 2х массивов? »
Не могу сказать. Мне даже алгоритм сложно понять, с массивами всегда так.

[blackeangel]

Iska, суть проста: берём 1 элемент из arr2( с листа экселя) и проверяем входит ли он в какой либо элемент массива arr1(взятого из sql таблицы). Если есть совпадение то "закидывает" в массив arr2 в соседний столбец массива.
Все остальное это доп надстройки-проверки.

[Iska]

Там очень много InStr().

[blackeangel]

Iska, это единственное что я знаю на проверку есть ли подстрока в строке.

[y--]

blackeangel, проверяем входит ли он в какой либо элемент массива arr1(взятого из sql таблицы) »а не проще пойти в другую сторону - загрузить таблицу из экселя в sql и уж его средствами проделать все необходимые манипуляции...
СУБД - специализированная система и все такое.
Важно только про всякие тримы и тому подобное при переносе не забыть...

[blackeangel]

y--, вот, тоже вариант, а можно подробнее?
Ссылки, примеры?
правда надо все делать средствами sql встроенными в vba, ТК акссес не у всех есть. Потом надо создать виртуальные таблицы, ТК запись на жёсткий ограничена.

[blackeangel]

Iska, в общем померил время. Все очень и очень грустно. Во первых в память все очень закидывается, аж целую минуту. Выкидывается на лист ещё дольше - 7 минут, все остальное время это цикл.
Для того чтобы понять на сколько все реально плохо решил на 6 строках попробовать. Время выполнения 10 сек. Причем запрос выполнялся 7 сек, все остальное цикл, считывание с листа, запись на лист. Но запрос делается один раз, ему простительно это все.

[blackeangel]

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

[blackeangel]

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

[blackeangel]

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

[Iska]

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

[blackeangel]

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

[Iska]

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

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

[blackeangel]

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

[Iska]

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

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

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

[y--]

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

[Iska]

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