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

Компьютерный форум 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

 

Ветеран


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

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


Цитата blackeangel:
Даже с простыми вхождениями в аксессе я не знаю как.(хотяб простое с наличием "-"). »
Sample.mdb.7z

Отправлено: 17:00, 04-12-2017 | #41



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

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


Аватара для blackeangel

Старожил


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

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


Iska, то есть для начала надо поштудировать вот это
https://www.google.ru/url?sa=t&sourc...eZZXo2lOk1wi5l

Iska, но меня терзает то, что я нигде не видел чтоб можно было создать файл базы и заполнить её данными из recordset.

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


Отправлено: 21:30, 04-12-2017 | #42


Ветеран


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

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


Цитата blackeangel:
Iska, то есть для начала надо поштудировать вот это
https://www.google.ru/url?sa=t&sourc...eZZXo2lOk1wi5l »
Можно, конечно, для общего развития, но там именно что DAO, а на ADO отведено три странички (проще говоря, всё, что там сказано — «есть такая технология»). DAO — более старая и ограниченная технология по сравнению с ADO.

Цитата blackeangel:
Iska, но меня терзает то, что я нигде не видел чтоб можно было создать файл базы и заполнить её данными из recordset. »
Продолжу задалбывать Вас терминологией. Это — ADOX. Вот пример работы, в качестве базы данных выступает текстовый файл. Прочие примеры, в том числе и реальными базами данных можно найти по запросу в Google «vbscript|VB|VBA ADOX database».
Это сообщение посчитали полезным следующие участники:

Отправлено: 22:08, 04-12-2017 | #43


Аватара для blackeangel

Старожил


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

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


Iska, так
Скрытый текст
Код: Выделить весь код
Sub KD5_Zapros()
    a = Timer
    Application.ScreenUpdating = False
    'удаляем предыдущую базу если вдруг есть ==>
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(ActiveWorkbook.FullName & ".mdb") Then fso.DeleteFile ActiveWorkbook.FullName & ".mdb", True
    'удаляем предыдущую базу если вдруг есть <==
    Dim dbConnectStr As String
    Dim Catalog As Object
    Dim cnt As ADODB.Connection
    Dim sCon$, rs As Object
    Dim sSQL$
    Set rs = CreateObject("ADODB.Recordset")
    'Module5.sboboz 'сборочные шаблоны
    'massoboz = Module5.oboz
    ncolumn = Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole).Column
    Columns(ncolumn + 1).Insert
    Cells(1, ncolumn + 1).Value = "Карточки"
    
    'сортировка ====>
    ActiveSheet.UsedRange.Select 'выделяем по тому что есть
    If ActiveSheet.AutoFilterMode = False Then 'если нет фильтра - ставим
        Selection.AutoFilter 'ставим фильтр
    End If
    ActiveWorkbook.Worksheets(ActiveSheet.Name).AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range(Cells(1, ncolumn), Cells(Rows.Count, ncolumn)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets(ActiveSheet.Name).AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.AutoFilter
    Range("A1").Select
    'сортировка <====
    
    'создаем файл
    Set Catalog = CreateObject("ADOX.Catalog")
    Catalog.Create dbConnectStr
    Set Catalog = Nothing
    
    'запрос с листа ====>
    Select Case CLng(Split(Application.Version, ".")(0))
        Case Is < 12
            sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ActiveWorkbook.FullName _
              & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
            dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ActiveWorkbook.FullName & ".mdb" & ";"
        Case Is >= 12
            sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName _
            & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
            dbConnectStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ".mdb" & ";"
    End Select
    
    Set cnt = New ADODB.Connection
    
    'создаем таблицы ==>
    With cnt
        .Open dbConnectStr
        .Execute "CREATE TABLE base ([Oboznach] text(50) WITH Compression, " & _
                 "[izm] text(50) WITH Compression, " & _
                 "[Count_page] text(50) WITH Compression)" 'таблица базы
    End With
    'создаем таблицы <==
    
    'заполняем с листа ==>
    sSQL = "SELECT [Обозначение] INTO list FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & ActiveWorkbook.FullName & "].[" & ActiveSheet.Name & "$]"
    Set rs = cnt.Execute(sSQL)
    'заполняем с листа <==
    
    'заполняем с сервера ==>
    'Set conn = New ADODB.Connection
    'conn.ConnectionString = "Provider=SQLOLEDB.1;Password=1qaz@WSX;Persist Security Info=True;User ID=User_for_macros_PDM;Initial Catalog=db_pdm_ScanKD;Data Source=RTVS-SQL05" 'Строка подключения
    'conn.Open
    'Set rst = New ADODB.Recordset
    'rst.ActiveConnection = conn
    'Ask = "SELECT [Oboznach],[izm],[Count_page], COUNT(*) as КоличествоЗаписей " _
    '& "FROM [db_pdm_ScanKD].[dbo].[pdm_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 '%Э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 '%ПГ3' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2') " _
    '& " GROUP BY [Oboznach],[izm],[Count_page]"
    'rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic
    'arr1 = rst.GetRows
    'conn.Closes
    'заполняем с сервера <==
    
    Application.ScreenUpdating = True
    cnt.Close
    MsgBox Timer - a
    Stop
End Sub

Как сделать запросом перенести таблицу из базы сервера в свою базу?

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


Последний раз редактировалось blackeangel, 05-12-2017 в 13:43.


Отправлено: 13:30, 05-12-2017 | #44


Ветеран


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

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


Цитата blackeangel:
Как сделать запросом перенести таблицу из базы сервера в свою базу? »
Я бы попрбовал SELECT … INTO …. Иначе обычный SELECT, затем перебор полученных записей и добавление в другой Recordset по одной по .AddNew().

Отправлено: 13:55, 05-12-2017 | #45


Аватара для blackeangel

Старожил


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

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


Iska, просто из экселя удалось одним select сразу в новый файл как таблицу нужный диапазон забросить. А вот из сервера что то никак не соображу. Пока весь код выполняется за 0.09сек, что неплохо.
Я склоняюсь в сторону select...into, но вот не могу понять как организовать from из того что у меня закоментировано в самом низу.

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


Отправлено: 13:59, 05-12-2017 | #46


Аватара для blackeangel

Старожил


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

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


Iska, нет, ваш пример не котируется, ТК не понятно как использовать instr между двумя таблицами, а не в пределах одной.

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


Отправлено: 07:59, 07-12-2017 | #47


Ветеран


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

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


blackeangel, какой именно пример, и что значит «использовать instr между двумя таблицами»?

Отправлено: 10:21, 07-12-2017 | #48


Аватара для blackeangel

Старожил


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

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


Iska, вот в этом посте http://forum.oszone.net/post-2782275-41.html
Цитата Iska:
использовать instr между двумя таблицами »
Сравнить содержимое двух таблиц разных столбцов. Типа что то
Код: Выделить весь код
InStr(1,[list].[stolbec], [base].[stolbc5])>0
Выдает ошибку синтаксиса.
Как что то похожее в запрос прикрутить?

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


Отправлено: 10:30, 07-12-2017 | #49


Ветеран


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

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


Цитата blackeangel:
Iska, вот в этом посте http://forum.oszone.net/post-2782275-41.html »
Ясно. Суть в том, что тот пример был ответом именно на процитированное там:
Цитата blackeangel:
Даже с простыми вхождениями в аксессе я не знаю как.(хотяб простое с наличием "-"). »
Не более.

Цитата blackeangel:
Сравнить содержимое двух таблиц разных столбцов. Типа что то
Код: Выделить весь код
InStr(1,[list].[stolbec], [base].[stolbc5])>0
Выдает ошибку синтаксиса.
Как что то похожее в запрос прикрутить? »
А причём тут синтаксис? Вы хотите сравнить содержимое некоего поля каждой из всех записей одной таблицы с неким полем каждой из всех записей другой таблицы, как я понимаю. Причём эти две таблицы никак и ничем не связаны, Вам как раз нужно найти их взаимосвязь по частичному вхождению. Но что Вы получите в итоге? Совсем не то, что ожидалось.

Давайте так. Вы сделаете две небольших, коротких таблицы в Microsoft Access. Сделаете третью таблицу, которую хотели бы получить из этих двух в итоге. Словами опишете, по какому принципу (не в терминах запросов, а просто словами) эта таблица строилась бы, если бы Вы делали всё «ручками» — то есть: смотрим сюда, берём вот это, ищем его здесь, найденное помещаем в новую таблицу и т.д.

Отправлено: 14:03, 07-12-2017 | #50



Компьютерный форум 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




 
Переход