Уважаемые коллеги! Передо мной стоит следующая задача. Есть некий каталог в формате "Код, название, территория" и усть две выгрузки из БД с данными за текущий и предыдущий периоды в формате "Код, данные". Необходимо получить сопоставление в формате "Код,название, территория, данные пред, данные тек", исключив при этом строки, в которых нет данных ни по текущему, ни по предыдущему периодам. Код заведомо уникален, Название может быть уникальным, а может не быть, Территория заведомо не уникальна. Сама задача не сложна и выполняется методами Find и AdvancedFilter. Проблема в том, что таких пар выгрузок несколько сотен, в каталоге порядка 3500 строк, а в каждой из выгрузок — от 2 до 2000. Поэтому весь массив информации макрос обрабатывает... эмм... не быстро (порядка 30 минут), а надобность в нём возникает как раз тогда, когда сроки поджимают. Поэтому хотелось бы доработать нижеприведённый код в части ускорения процесса хотя бы процентов на 10. [vba]
Код
Sub Unionist()
Dim i, j As Long 'Счётчики Dim FilePath As String 'Буферная строка для путей к файлам
Уважаемые коллеги! Передо мной стоит следующая задача. Есть некий каталог в формате "Код, название, территория" и усть две выгрузки из БД с данными за текущий и предыдущий периоды в формате "Код, данные". Необходимо получить сопоставление в формате "Код,название, территория, данные пред, данные тек", исключив при этом строки, в которых нет данных ни по текущему, ни по предыдущему периодам. Код заведомо уникален, Название может быть уникальным, а может не быть, Территория заведомо не уникальна. Сама задача не сложна и выполняется методами Find и AdvancedFilter. Проблема в том, что таких пар выгрузок несколько сотен, в каталоге порядка 3500 строк, а в каждой из выгрузок — от 2 до 2000. Поэтому весь массив информации макрос обрабатывает... эмм... не быстро (порядка 30 минут), а надобность в нём возникает как раз тогда, когда сроки поджимают. Поэтому хотелось бы доработать нижеприведённый код в части ускорения процесса хотя бы процентов на 10. [vba]
Код
Sub Unionist()
Dim i, j As Long 'Счётчики Dim FilePath As String 'Буферная строка для путей к файлам
[/vba] FilePath примет значение последней строки. а такое [vba]
Код
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
[/vba] на каждом этапе цикла программа считает выражение [vba]
Код
Cells(Rows.Count, 1).End(xlUp).Row
[/vba] Проще ввести переменную и записать туда: [vba]
Код
i_n =Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To i_n
[/vba]
Ну и я бы попробовал записать данные из книг "Текущий" и "Предыдущий в 2 словаря и воспользоваться методом .exists(key), мне кажется будет быстрее...Roman777
Много чего не знаю!!!!
Сообщение отредактировал Roman777 - Суббота, 05.03.2016, 18:13
Эта переменная введена вообще только из любезности к читателям кода на форуме, в "боевом" коде пути прописаны непосредственно в Workbooks.Open.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
1. Загнать каталог в словарь 2. В цикле открывать/закрывать книги, загонять данные в массив, проводить обработку, выгружать. Время работы (теоретически) - время открытия/закрытия книг + 10%.
1. Загнать каталог в словарь 2. В цикле открывать/закрывать книги, загонять данные в массив, проводить обработку, выгружать. Время работы (теоретически) - время открытия/закрытия книг + 10%.RAN
если я всё равно сначала всё вешаю на каталог, потом убираю из него лишнее. Ну будет у меня Workbooks.Add вместо открытия каталога. Это быстрее?StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
В принципе я думаю в ту сторону, что не упустил ли я какой метод, позволяющий вместо затратного перебора 3500 строк применить аналог SQL'ного Select'а...
В принципе я думаю в ту сторону, что не упустил ли я какой метод, позволяющий вместо затратного перебора 3500 строк применить аналог SQL'ного Select'а...StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Sub Unionist() Dim a, b, c, ws As Worksheet, d As Object Dim i, j As Long 'Счётчики Dim FilePath As String 'Буферная строка для путей к файлам
Application.DisplayAlerts = False Application.ScreenUpdating = False Set d = CreateObject("scripting.dictionary") FilePath = ThisWorkbook.Path & "\Предыдущий.xlsx" With Workbooks.Open(FilePath) 'Открываем файл с предыдущими данными b = .Sheets(1).[a1].CurrentRegion.Value .Close 0 End With
FilePath = ThisWorkbook.Path & "\Текущий.xlsx"
With Workbooks.Open(FilePath) 'Открываем файл с текущими данными c = .Sheets(1).[a1].CurrentRegion.Value .Close 0 End With
FilePath = ThisWorkbook.Path & "\Каталог.xlsx" With Workbooks.Open(FilePath).Sheets(1) 'Открываем файл с каталогом
.Cells(1, 4).Value = "Пред" 'Делаем заголовки .Cells(1, 5).Value = "Тек" a = .[a1].CurrentRegion.Value For i = 2 To UBound(a) 'Крутимся до конца таблицы d.Item(a(i, 1)) = i Next i For i = 2 To UBound(b) 'Крутимся до конца таблицы a(d.Item(b(i, 1)), 4) = b(i, 2) Next i For i = 2 To UBound(c) 'Крутимся до конца таблицы a(d.Item(c(i, 1)), 5) = c(i, 2) Next i .[a1].Resize(UBound(a), 5) = a
.Cells(1, 7).Value = "Нули" 'Делаем заголовок для фильтра Range(.Cells(2, 7), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 7)).FormulaR1C1 = "=RC[-3]+RC[-2]=0" 'Ищем строки, в которых нет данных .Cells(1, 8).Value = "Нули" 'Делаем заголовок для CriteriaRnge .Cells(2, 8).Value = False 'Формируем сам CriteriaRnge Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 7)).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range(Cells(1, 8), Cells(2, 8)), CopyToRange:=Cells(1, 10), Unique:=False 'Фильтуем .Columns("A:I").Delete 'Удаляем лишние колонки .Columns(7).Delete
FilePath = ThisWorkbook.Path & "\Результат.xlsx" .Parent.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Сохраняемся под нужным именем .Parent.Close 0 End With Application.DisplayAlerts = True Application.ScreenUpdating = True
End Sub
[/vba]
[vba]
Код
Sub Unionist() Dim a, b, c, ws As Worksheet, d As Object Dim i, j As Long 'Счётчики Dim FilePath As String 'Буферная строка для путей к файлам
Application.DisplayAlerts = False Application.ScreenUpdating = False Set d = CreateObject("scripting.dictionary") FilePath = ThisWorkbook.Path & "\Предыдущий.xlsx" With Workbooks.Open(FilePath) 'Открываем файл с предыдущими данными b = .Sheets(1).[a1].CurrentRegion.Value .Close 0 End With
FilePath = ThisWorkbook.Path & "\Текущий.xlsx"
With Workbooks.Open(FilePath) 'Открываем файл с текущими данными c = .Sheets(1).[a1].CurrentRegion.Value .Close 0 End With
FilePath = ThisWorkbook.Path & "\Каталог.xlsx" With Workbooks.Open(FilePath).Sheets(1) 'Открываем файл с каталогом
.Cells(1, 4).Value = "Пред" 'Делаем заголовки .Cells(1, 5).Value = "Тек" a = .[a1].CurrentRegion.Value For i = 2 To UBound(a) 'Крутимся до конца таблицы d.Item(a(i, 1)) = i Next i For i = 2 To UBound(b) 'Крутимся до конца таблицы a(d.Item(b(i, 1)), 4) = b(i, 2) Next i For i = 2 To UBound(c) 'Крутимся до конца таблицы a(d.Item(c(i, 1)), 5) = c(i, 2) Next i .[a1].Resize(UBound(a), 5) = a
.Cells(1, 7).Value = "Нули" 'Делаем заголовок для фильтра Range(.Cells(2, 7), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 7)).FormulaR1C1 = "=RC[-3]+RC[-2]=0" 'Ищем строки, в которых нет данных .Cells(1, 8).Value = "Нули" 'Делаем заголовок для CriteriaRnge .Cells(2, 8).Value = False 'Формируем сам CriteriaRnge Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 7)).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range(Cells(1, 8), Cells(2, 8)), CopyToRange:=Cells(1, 10), Unique:=False 'Фильтуем .Columns("A:I").Delete 'Удаляем лишние колонки .Columns(7).Delete
FilePath = ThisWorkbook.Path & "\Результат.xlsx" .Parent.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Сохраняемся под нужным именем .Parent.Close 0 End With Application.DisplayAlerts = True Application.ScreenUpdating = True
StoTisteg, до словарей поздно додумалась, у меня только один словарик для первого столбца. Сами данные в массиве. Мне всегда казалось, что Find достаточно быстро работает... Если не понравиться, можете переписать кусок с предыдущей и текущей книгой по аналогии, все в массивы и работать с ними, а не с листом, как посоветовал RAN. Я сейчас убегаю и дописывать некогда.
Попробуйте пока такой вариант [vba]
Код
Sub Unionist()
Dim i&, j&, k& 'Счётчики Dim r, res() Dim FilePath As String 'Буферная строка для путей к файлам
FilePath = ThisWorkbook.Path & "\Предыдущий.xlsx" Workbooks.Open Filename:=FilePath 'Открываем файл с предыдущими данными FilePath = ThisWorkbook.Path & "\Текущий.xlsx" Workbooks.Open Filename:=FilePath 'Открываем файл с текущими данными FilePath = ThisWorkbook.Path & "\Каталог.xlsx" Workbooks.Open Filename:=FilePath 'Открываем файл с каталогом Cells(1, 4).Value = "Пред" 'Делаем заголовки Cells(1, 5).Value = "Тек" For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row 'Крутимся до конца таблицы With Workbooks("Предыдущий.xlsx").Worksheets(1) On Error Resume Next Cells(i, 4).Value = .Columns(1).Find(what:=Cells(i, 1).Value, LookAt:=xlWhole).Offset(, 1) 'Находим и вставляем предыдущие данные Err.Clear End With With Workbooks("Текущий.xlsx").Worksheets(1) On Error Resume Next Cells(i, 5).Value = .Columns(1).Find(what:=Cells(i, 1).Value, LookAt:=xlWhole).Offset(, 1) '... и текущие Err.Clear End With Next i On Error GoTo 0 Workbooks("Предыдущий.xlsx").Close 'Закрываем ненужное Workbooks("Текущий.xlsx").Close r = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)).Value Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)).ClearContents Set dic = CreateObject("Scripting.Dictionary") ReDim Preserve res(4, UBound(r, 1)) For i = 2 To UBound(r, 1) If r(i, 4) + r(i, 5) <> 0 Then If Not dic.Exists(r(i, 1)) Then For j = 0 To 4 res(j, k) = r(i, j + 1) Next j dic.Add r(i, 1), k k = k + 1 End If End If Next i Cells(2, 1).Resize(k, 5) = WorksheetFunction.Transpose(res) FilePath = ThisWorkbook.Path & "\Результат.xlsx" ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Сохраняемся под нужным именем ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
[/vba]
StoTisteg, до словарей поздно додумалась, у меня только один словарик для первого столбца. Сами данные в массиве. Мне всегда казалось, что Find достаточно быстро работает... Если не понравиться, можете переписать кусок с предыдущей и текущей книгой по аналогии, все в массивы и работать с ними, а не с листом, как посоветовал RAN. Я сейчас убегаю и дописывать некогда.
Попробуйте пока такой вариант [vba]
Код
Sub Unionist()
Dim i&, j&, k& 'Счётчики Dim r, res() Dim FilePath As String 'Буферная строка для путей к файлам
FilePath = ThisWorkbook.Path & "\Предыдущий.xlsx" Workbooks.Open Filename:=FilePath 'Открываем файл с предыдущими данными FilePath = ThisWorkbook.Path & "\Текущий.xlsx" Workbooks.Open Filename:=FilePath 'Открываем файл с текущими данными FilePath = ThisWorkbook.Path & "\Каталог.xlsx" Workbooks.Open Filename:=FilePath 'Открываем файл с каталогом Cells(1, 4).Value = "Пред" 'Делаем заголовки Cells(1, 5).Value = "Тек" For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row 'Крутимся до конца таблицы With Workbooks("Предыдущий.xlsx").Worksheets(1) On Error Resume Next Cells(i, 4).Value = .Columns(1).Find(what:=Cells(i, 1).Value, LookAt:=xlWhole).Offset(, 1) 'Находим и вставляем предыдущие данные Err.Clear End With With Workbooks("Текущий.xlsx").Worksheets(1) On Error Resume Next Cells(i, 5).Value = .Columns(1).Find(what:=Cells(i, 1).Value, LookAt:=xlWhole).Offset(, 1) '... и текущие Err.Clear End With Next i On Error GoTo 0 Workbooks("Предыдущий.xlsx").Close 'Закрываем ненужное Workbooks("Текущий.xlsx").Close r = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)).Value Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)).ClearContents Set dic = CreateObject("Scripting.Dictionary") ReDim Preserve res(4, UBound(r, 1)) For i = 2 To UBound(r, 1) If r(i, 4) + r(i, 5) <> 0 Then If Not dic.Exists(r(i, 1)) Then For j = 0 To 4 res(j, k) = r(i, j + 1) Next j dic.Add r(i, 1), k k = k + 1 End If End If Next i Cells(2, 1).Resize(k, 5) = WorksheetFunction.Transpose(res) FilePath = ThisWorkbook.Path & "\Результат.xlsx" ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Сохраняемся под нужным именем ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
Мне всегда казалось, что Find достаточно быстро работает...
Мне тоже. Пока я собственным рукомеслом не убедился на листе с полутора миллионами строк, что в отсортированном по возрастанию диапазоне самописный дихотомический поиск быстрее Find процентов на 10 Для небольших таблиц это, однако, не так.
Мне всегда казалось, что Find достаточно быстро работает...
Мне тоже. Пока я собственным рукомеслом не убедился на листе с полутора миллионами строк, что в отсортированном по возрастанию диапазоне самописный дихотомический поиск быстрее Find процентов на 10 Для небольших таблиц это, однако, не так.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Мой ник соответствует профессии. У нас и не такое бывает. А всего строк на листе, как известно, 2^20. То есть полутора миллионов там, конечно, не было, но больше миллиона точно...
Мой ник соответствует профессии. У нас и не такое бывает. А всего строк на листе, как известно, 2^20. То есть полутора миллионов там, конечно, не было, но больше миллиона точно...StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Его первая строка выполняется только один раз, так что эту операцию делает за меня VBA.
Для небольших таблиц это, однако, не так.
