Добрый день! У меня есть макрос, который обрабатывает базу в 500000 строк следующим образом: есть база, в каждой строке которой имеются цифровые и численно-буквенные сочетания(коды и номера артикулов), а также файл со списком всевозможных кодов -построен список в порядке убывания: т.е. вначале самые длинные коды содержащие буквы, а затем только численные. Число кодов в списке также очень велико = 750 000. Макрос проработал 63 часа и при этом не обработал и трети базы. Есть возможность ускорить работу программы или это не возможно?
Добрый день! У меня есть макрос, который обрабатывает базу в 500000 строк следующим образом: есть база, в каждой строке которой имеются цифровые и численно-буквенные сочетания(коды и номера артикулов), а также файл со списком всевозможных кодов -построен список в порядке убывания: т.е. вначале самые длинные коды содержащие буквы, а затем только численные. Число кодов в списке также очень велико = 750 000. Макрос проработал 63 часа и при этом не обработал и трети базы. Есть возможность ускорить работу программы или это не возможно?hatter
Option Explicit ': Option Compare Text Public Declare Function timeGetTime Lib "winmm.dll" () As Long Public Const kk As Long = 1 ' номер столбца описание товара Public Const kk1 As Long = 3 'номер столбца БТ2 Public Const nn1 As String = "БТема.xlsx" 'Название книги Sub Dk_1() Dim a(), b(), ii&, i&, x&, d&, z&, j&, c(), t& Dim vb As Worksheet, s$, ss$, sa$, vn As Worksheet t = timeGetTime With ThisWorkbook.ActiveSheet .Activate 'Select x = .Cells(.Rows.Count, kk).End(xlUp).Row a = Range(.Cells(2, kk), .Cells(x, kk)) End With Set vb = ActiveSheet ''Добавлять сюда в конец: "(", ")", "s" ) c = Array(" ", ",", ".", "-", "_", "+", "*", "\", "/", "[", "]", "{", "}", "'", ";", ":", "=", """", "(", ")") With CreateObject("Scripting.Dictionary"): .CompareMode = 1 For i = 0 To UBound(c) .Item(c(i)) = .Item(c(i)) + 1 Next For ii = 1 To UBound(a) If 0 = (ii Mod 1000) Then Application.StatusBar = "Подготовка строк " & ii s = LCase(Trim(a(ii, 1))) ss = "" For i = 1 To Len(s) sa = Mid(s, i, 1) If Not (.Exists(sa)) Then ss = ss & sa Next i If IsNumeric(Mid(ss, 1, 1)) Then ss = Mid(ss, 2, Len(ss)) a(ii, 1) = ss Next ii Columns(kk).ClearContents Cells(2, kk).Resize(x - 1, 1) = a Windows(nn1).Activate Set vn = ActiveSheet With vn .Activate z = .Cells(.Rows.Count, 1).End(xlUp).Row d = .Cells(.Rows.Count, 2).End(xlUp).Row j = .Cells(.Rows.Count, 3).End(xlUp).Row If z < d Then z = d If z < j Then z = j End With b = Range(Cells(2, 1), Cells(z, 3)) For ii = 1 To UBound(b) If 0 = (ii Mod 5000) Then Application.StatusBar = "Готовим строки " & ii s = LCase(Trim(b(ii, 1))) ss = "" For i = 1 To Len(s) sa = Mid(s, i, 1) If Not (.Exists(sa)) Then ss = ss & sa Next i b(ii, 1) = ss Next ii Columns("a:a").ClearContents [a2].Resize(z - 1, 1) = b '''''''''''''''''' Columns("a:a").NumberFormat = "@" .RemoveAll End With vb.Activate: d = 0 If Len(Cells(1, 100)) Then j = Cells(1, 100) Else j = 1 End If For i = j To UBound(a) 'x If 0 = (i Mod 50) Then Cells(1, 100) = i Application.StatusBar = "Обработано строк " & i & " найдено " & d End If 'сохранение каждых 5000 строк ' If 0 = (i Mod 5000) Then ThisWorkbook.Save
For ii = 1 To UBound(b) 'z If Len(Cells(i + 1, kk1)) <> 0 Or Len(Cells(i + 1, kk1 + 1)) <> 0 Then Exit For If InStr(1, a(i, 1), b(ii, 1), vbBinaryCompare) Then Cells(i + 1, kk1) = b(ii, 2) Cells(i + 1, kk1 + 1) = b(ii, 3): d = d + 1 Exit For End If Next: Next Application.StatusBar = False Cells(1, kk + 1) = timeGetTime - t & " ìèëèñåê" Cells(1, kk + 2) = d & " íàéäåíî" End Sub Sub cilki() If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 Else Application.ReferenceStyle = xlR1C1 End If End Sub
[/vba]
Вот мой код: [vba]
Код
Option Explicit ': Option Compare Text Public Declare Function timeGetTime Lib "winmm.dll" () As Long Public Const kk As Long = 1 ' номер столбца описание товара Public Const kk1 As Long = 3 'номер столбца БТ2 Public Const nn1 As String = "БТема.xlsx" 'Название книги Sub Dk_1() Dim a(), b(), ii&, i&, x&, d&, z&, j&, c(), t& Dim vb As Worksheet, s$, ss$, sa$, vn As Worksheet t = timeGetTime With ThisWorkbook.ActiveSheet .Activate 'Select x = .Cells(.Rows.Count, kk).End(xlUp).Row a = Range(.Cells(2, kk), .Cells(x, kk)) End With Set vb = ActiveSheet ''Добавлять сюда в конец: "(", ")", "s" ) c = Array(" ", ",", ".", "-", "_", "+", "*", "\", "/", "[", "]", "{", "}", "'", ";", ":", "=", """", "(", ")") With CreateObject("Scripting.Dictionary"): .CompareMode = 1 For i = 0 To UBound(c) .Item(c(i)) = .Item(c(i)) + 1 Next For ii = 1 To UBound(a) If 0 = (ii Mod 1000) Then Application.StatusBar = "Подготовка строк " & ii s = LCase(Trim(a(ii, 1))) ss = "" For i = 1 To Len(s) sa = Mid(s, i, 1) If Not (.Exists(sa)) Then ss = ss & sa Next i If IsNumeric(Mid(ss, 1, 1)) Then ss = Mid(ss, 2, Len(ss)) a(ii, 1) = ss Next ii Columns(kk).ClearContents Cells(2, kk).Resize(x - 1, 1) = a Windows(nn1).Activate Set vn = ActiveSheet With vn .Activate z = .Cells(.Rows.Count, 1).End(xlUp).Row d = .Cells(.Rows.Count, 2).End(xlUp).Row j = .Cells(.Rows.Count, 3).End(xlUp).Row If z < d Then z = d If z < j Then z = j End With b = Range(Cells(2, 1), Cells(z, 3)) For ii = 1 To UBound(b) If 0 = (ii Mod 5000) Then Application.StatusBar = "Готовим строки " & ii s = LCase(Trim(b(ii, 1))) ss = "" For i = 1 To Len(s) sa = Mid(s, i, 1) If Not (.Exists(sa)) Then ss = ss & sa Next i b(ii, 1) = ss Next ii Columns("a:a").ClearContents [a2].Resize(z - 1, 1) = b '''''''''''''''''' Columns("a:a").NumberFormat = "@" .RemoveAll End With vb.Activate: d = 0 If Len(Cells(1, 100)) Then j = Cells(1, 100) Else j = 1 End If For i = j To UBound(a) 'x If 0 = (i Mod 50) Then Cells(1, 100) = i Application.StatusBar = "Обработано строк " & i & " найдено " & d End If 'сохранение каждых 5000 строк ' If 0 = (i Mod 5000) Then ThisWorkbook.Save
For ii = 1 To UBound(b) 'z If Len(Cells(i + 1, kk1)) <> 0 Or Len(Cells(i + 1, kk1 + 1)) <> 0 Then Exit For If InStr(1, a(i, 1), b(ii, 1), vbBinaryCompare) Then Cells(i + 1, kk1) = b(ii, 2) Cells(i + 1, kk1 + 1) = b(ii, 3): d = d + 1 Exit For End If Next: Next Application.StatusBar = False Cells(1, kk + 1) = timeGetTime - t & " ìèëèñåê" Cells(1, kk + 2) = d & " íàéäåíî" End Sub Sub cilki() If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 Else Application.ReferenceStyle = xlR1C1 End If End Sub
Без файла что гадать, но, думаю из 63 часов 60,5 ушло сюда [vba]
Код
For i = j To UBound(a) 'x If 0 = (i Mod 50) Then Cells(1, 100) = i Application.StatusBar = "Обработано строк " & i & " найдено " & d End If 'сохранение каждых 5000 строк ' If 0 = (i Mod 5000) Then ThisWorkbook.Save
For ii = 1 To UBound(b) 'z If Len(Cells(i + 1, kk1)) <> 0 Or Len(Cells(i + 1, kk1 + 1)) <> 0 Then Exit For If InStr(1, a(i, 1), b(ii, 1), vbBinaryCompare) Then Cells(i + 1, kk1) = b(ii, 2) Cells(i + 1, kk1 + 1) = b(ii, 3): d = d + 1 Exit For End If
[/vba]
Без файла что гадать, но, думаю из 63 часов 60,5 ушло сюда [vba]
Код
For i = j To UBound(a) 'x If 0 = (i Mod 50) Then Cells(1, 100) = i Application.StatusBar = "Обработано строк " & i & " найдено " & d End If 'сохранение каждых 5000 строк ' If 0 = (i Mod 5000) Then ThisWorkbook.Save
For ii = 1 To UBound(b) 'z If Len(Cells(i + 1, kk1)) <> 0 Or Len(Cells(i + 1, kk1 + 1)) <> 0 Then Exit For If InStr(1, a(i, 1), b(ii, 1), vbBinaryCompare) Then Cells(i + 1, kk1) = b(ii, 2) Cells(i + 1, kk1 + 1) = b(ii, 3): d = d + 1 Exit For End If
Да, спасибо, я знаю что access лучше, но покамест данные лежат в екселе и нужно что-то с ними сделать. Прикладываю 2 файла: один кусок из базы и второй- файл-источник с кодами, по которым ведется поиск в базе и проставляются название соответствующего поставщика в 4-1 столбец.
Да, спасибо, я знаю что access лучше, но покамест данные лежат в екселе и нужно что-то с ними сделать. Прикладываю 2 файла: один кусок из базы и второй- файл-источник с кодами, по которым ведется поиск в базе и проставляются название соответствующего поставщика в 4-1 столбец.hatter