Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сопоставление данных с каталогом: оптимизация по времени - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сопоставление данных с каталогом: оптимизация по времени (Макросы/Sub)
Сопоставление данных с каталогом: оптимизация по времени
StoTisteg Дата: Суббота, 05.03.2016, 17:28 | Сообщение № 1
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
Уважаемые коллеги!
Передо мной стоит следующая задача. Есть некий каталог в формате "Код, название, территория" и усть две выгрузки из БД с данными за текущий и предыдущий периоды в формате "Код, данные". Необходимо получить сопоставление в формате "Код,название, территория, данные пред, данные тек", исключив при этом строки, в которых нет данных ни по текущему, ни по предыдущему периодам. Код заведомо уникален, Название может быть уникальным, а может не быть, Территория заведомо не уникальна.
Сама задача не сложна и выполняется методами Find и AdvancedFilter. Проблема в том, что таких пар выгрузок несколько сотен, в каталоге порядка 3500 строк, а в каждой из выгрузок — от 2 до 2000. Поэтому весь массив информации макрос обрабатывает... эмм... не быстро (порядка 30 минут), а надобность в нём возникает как раз тогда, когда сроки поджимают. Поэтому хотелось бы доработать нижеприведённый код в части ускорения процесса хотя бы процентов на 10.
[vba]
Код
Sub Unionist()
    
    Dim i, j As Long 'Счётчики
    Dim FilePath As String 'Буферная строка для путей к файлам
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    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
    Workbooks("Предыдущий.xlsx").Close 'Закрываем ненужное
    Workbooks("Текущий.xlsx").Close
    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"
    ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Сохраняемся под нужным именем
    ActiveWorkbook.Close

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
[/vba]
К сообщению приложен файл: Union.rar(39Kb)


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал StoTisteg - Суббота, 05.03.2016, 17:28
 
Ответить
СообщениеУважаемые коллеги!
Передо мной стоит следующая задача. Есть некий каталог в формате "Код, название, территория" и усть две выгрузки из БД с данными за текущий и предыдущий периоды в формате "Код, данные". Необходимо получить сопоставление в формате "Код,название, территория, данные пред, данные тек", исключив при этом строки, в которых нет данных ни по текущему, ни по предыдущему периодам. Код заведомо уникален, Название может быть уникальным, а может не быть, Территория заведомо не уникальна.
Сама задача не сложна и выполняется методами Find и AdvancedFilter. Проблема в том, что таких пар выгрузок несколько сотен, в каталоге порядка 3500 строк, а в каждой из выгрузок — от 2 до 2000. Поэтому весь массив информации макрос обрабатывает... эмм... не быстро (порядка 30 минут), а надобность в нём возникает как раз тогда, когда сроки поджимают. Поэтому хотелось бы доработать нижеприведённый код в части ускорения процесса хотя бы процентов на 10.
[vba]
Код
Sub Unionist()
    
    Dim i, j As Long 'Счётчики
    Dim FilePath As String 'Буферная строка для путей к файлам
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    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
    Workbooks("Предыдущий.xlsx").Close 'Закрываем ненужное
    Workbooks("Текущий.xlsx").Close
    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"
    ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Сохраняемся под нужным именем
    ActiveWorkbook.Close

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
[/vba]

Автор - StoTisteg
Дата добавления - 05.03.2016 в 17:28
Roman777 Дата: Суббота, 05.03.2016, 18:03 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 703
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
StoTisteg, очень странно, но мне кажется, что после
[vba]
Код
    FilePath = ThisWorkbook.Path & "\Предыдущий.xlsx"
    Workbooks.Open Filename:=FilePath 'Открываем файл с предыдущими данными
    FilePath = ThisWorkbook.Path & "\Текущий.xlsx"
    Workbooks.Open Filename:=FilePath 'Открываем файл с текущими данными
    FilePath = ThisWorkbook.Path & "\Каталог.xlsx"
[/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 - Суббота, 05.03.2016, 18:13
 
Ответить
СообщениеStoTisteg, очень странно, но мне кажется, что после
[vba]
Код
    FilePath = ThisWorkbook.Path & "\Предыдущий.xlsx"
    Workbooks.Open Filename:=FilePath 'Открываем файл с предыдущими данными
    FilePath = ThisWorkbook.Path & "\Текущий.xlsx"
    Workbooks.Open Filename:=FilePath 'Открываем файл с текущими данными
    FilePath = ThisWorkbook.Path & "\Каталог.xlsx"
[/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
Дата добавления - 05.03.2016 в 18:03
StoTisteg Дата: Суббота, 05.03.2016, 18:19 | Сообщение № 3
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
на каждом этапе цикла программа считает выражение

Погоняйте цикл For в режиме F8 ;) Его первая строка выполняется только один раз, так что эту операцию делает за меня VBA.
FilePath примет значение последней строки

Эта переменная введена вообще только из любезности к читателям кода на форуме, в "боевом" коде пути прописаны непосредственно в Workbooks.Open.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
Сообщение
на каждом этапе цикла программа считает выражение

Погоняйте цикл For в режиме F8 ;) Его первая строка выполняется только один раз, так что эту операцию делает за меня VBA.
FilePath примет значение последней строки

Эта переменная введена вообще только из любезности к читателям кода на форуме, в "боевом" коде пути прописаны непосредственно в Workbooks.Open.

Автор - StoTisteg
Дата добавления - 05.03.2016 в 18:19
RAN Дата: Суббота, 05.03.2016, 18:19 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4277
Репутация: 829 ±
Замечаний: 0% ±

2010
1. Загнать каталог в словарь
2. В цикле открывать/закрывать книги, загонять данные в массив, проводить обработку, выгружать.
Время работы (теоретически) - время открытия/закрытия книг + 10%.


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение1. Загнать каталог в словарь
2. В цикле открывать/закрывать книги, загонять данные в массив, проводить обработку, выгружать.
Время работы (теоретически) - время открытия/закрытия книг + 10%.

Автор - RAN
Дата добавления - 05.03.2016 в 18:19
StoTisteg Дата: Суббота, 05.03.2016, 18:28 | Сообщение № 5
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
Время работы (теоретически) - время открытия/закрытия книг + 10%

Это понятное дело, что открытие книг занимает основное время. Но не очень понятно, что даст
Загнать каталог в словарь

если я всё равно сначала всё вешаю на каталог, потом убираю из него лишнее. Ну будет у меня Workbooks.Add вместо открытия каталога. Это быстрее?


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
Сообщение
Время работы (теоретически) - время открытия/закрытия книг + 10%

Это понятное дело, что открытие книг занимает основное время. Но не очень понятно, что даст
Загнать каталог в словарь

если я всё равно сначала всё вешаю на каталог, потом убираю из него лишнее. Ну будет у меня Workbooks.Add вместо открытия каталога. Это быстрее?

Автор - StoTisteg
Дата добавления - 05.03.2016 в 18:28
StoTisteg Дата: Суббота, 05.03.2016, 18:32 | Сообщение № 6
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
В принципе я думаю в ту сторону, что не упустил ли я какой метод, позволяющий вместо затратного перебора 3500 строк применить аналог SQL'ного Select'а...


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеВ принципе я думаю в ту сторону, что не упустил ли я какой метод, позволяющий вместо затратного перебора 3500 строк применить аналог SQL'ного Select'а...

Автор - StoTisteg
Дата добавления - 05.03.2016 в 18:32
StoTisteg Дата: Суббота, 05.03.2016, 18:45 | Сообщение № 7
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
Ну будет у меня Workbooks.Add вместо открытия каталога. Это быстрее?

Извиняюсь, протупил. Разумеется, создать новую пустую книгу быстрее, чем открыть большую и тяжёлую :)


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
Сообщение
Ну будет у меня Workbooks.Add вместо открытия каталога. Это быстрее?

Извиняюсь, протупил. Разумеется, создать новую пустую книгу быстрее, чем открыть большую и тяжёлую :)

Автор - StoTisteg
Дата добавления - 05.03.2016 в 18:45
KuklP Дата: Суббота, 05.03.2016, 18:50 | Сообщение № 8
Группа: Проверенные
Ранг: Старожил
Сообщений: 1996
Репутация: 436 ±
Замечаний: 0% ±

[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

    End Sub
[/vba]


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728
 
Ответить
Сообщение[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

    End Sub
[/vba]

Автор - KuklP
Дата добавления - 05.03.2016 в 18:50
Manyasha Дата: Суббота, 05.03.2016, 18:51 | Сообщение № 9
Группа: Модераторы
Ранг: Старожил
Сообщений: 1586
Репутация: 661 ±
Замечаний: 0% ±

Excel 2007, 2010
StoTisteg, до словарей поздно додумалась, у меня только один словарик для первого столбца.
Сами данные в массиве.
Мне всегда казалось, что Find достаточно быстро работает... Если не понравиться, можете переписать кусок с предыдущей и текущей книгой по аналогии, все в массивы и работать с ними, а не с листом, как посоветовал RAN. Я сейчас убегаю и дописывать некогда.

Попробуйте пока такой вариант
[vba]
Код
Sub Unionist()
    
    Dim i&, j&, k& 'Счётчики
    Dim r, res()
    Dim FilePath As String 'Буферная строка для путей к файлам
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    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]
К сообщению приложен файл: -1.xlsm(20Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеStoTisteg, до словарей поздно додумалась, у меня только один словарик для первого столбца.
Сами данные в массиве.
Мне всегда казалось, что Find достаточно быстро работает... Если не понравиться, можете переписать кусок с предыдущей и текущей книгой по аналогии, все в массивы и работать с ними, а не с листом, как посоветовал RAN. Я сейчас убегаю и дописывать некогда.

Попробуйте пока такой вариант
[vba]
Код
Sub Unionist()
    
    Dim i&, j&, k& 'Счётчики
    Dim r, res()
    Dim FilePath As String 'Буферная строка для путей к файлам
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    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]

Автор - Manyasha
Дата добавления - 05.03.2016 в 18:51
StoTisteg Дата: Суббота, 05.03.2016, 18:58 | Сообщение № 10
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
Мне всегда казалось, что Find достаточно быстро работает...

Мне тоже. Пока я собственным рукомеслом не убедился на листе с полутора миллионами строк, что в отсортированном по возрастанию диапазоне самописный дихотомический поиск быстрее Find процентов на 10 :o Для небольших таблиц это, однако, не так.


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
Сообщение
Мне всегда казалось, что Find достаточно быстро работает...

Мне тоже. Пока я собственным рукомеслом не убедился на листе с полутора миллионами строк, что в отсортированном по возрастанию диапазоне самописный дихотомический поиск быстрее Find процентов на 10 :o Для небольших таблиц это, однако, не так.

Автор - StoTisteg
Дата добавления - 05.03.2016 в 18:58
nilem Дата: Суббота, 05.03.2016, 19:31 | Сообщение № 11
Группа: Авторы
Ранг: Ветеран
Сообщений: 1054
Репутация: 398 ±
Замечаний: 0% ±

Excel 2013
на листе с полутора миллионами строк,

бывает такое?


Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem - Суббота, 05.03.2016, 19:33
 
Ответить
Сообщение
на листе с полутора миллионами строк,

бывает такое?

Автор - nilem
Дата добавления - 05.03.2016 в 19:31
StoTisteg Дата: Суббота, 05.03.2016, 20:40 | Сообщение № 12
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
Мой ник соответствует профессии. У нас и не такое бывает. А всего строк на листе, как известно, 2^20. То есть полутора миллионов там, конечно, не было, но больше миллиона точно...


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеМой ник соответствует профессии. У нас и не такое бывает. А всего строк на листе, как известно, 2^20. То есть полутора миллионов там, конечно, не было, но больше миллиона точно...

Автор - StoTisteg
Дата добавления - 05.03.2016 в 20:40
StoTisteg Дата: Суббота, 05.03.2016, 20:46 | Сообщение № 13
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
В общем, всем спасибо. Подтолкнули думалку в нужную сторону, дальше я сам yes


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеВ общем, всем спасибо. Подтолкнули думалку в нужную сторону, дальше я сам yes

Автор - StoTisteg
Дата добавления - 05.03.2016 в 20:46
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сопоставление данных с каталогом: оптимизация по времени (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!