Привет, коллеги. Прошу помочь с алгоритмом, теоретической подготовки не хватает.
Суть в следующем. Есть книга с двумя (на самом деле гораздо больше) листами. На одном из них (назовем его Лист1) несколько десятков или даже сотен тысяч записей, которые постоянно обновляются и пополняются копированием-вставкой из внешнего источника. Данные на этом листе не упорядочены, и содержат графы "дата", "ID", некая "сумма", и много всего прочего. На другом листе (Лист2) нужно макросом сформировать типа сводного отчета, в котором данные первого листа подсуммируются по "дате" + "ID". Есть рабочее решение, но оно слишком медленно, поэтому и прошу подсказки. Суть моего макроса состоит в том, что содержимое обоих листов считывается в два массива, потом двумя вложенными FOR даные суммируются (внешний for пробегает больший массив1, а внутренний накапливает в меньшем массиве2 суммы по заданным условиям), затем меньший массив заливается обратно на Лист2 конструкцией типа cells(...).resize(...).value = arr. Этот макрос работает несколько минут, что очень долго, учитывая прочие условия задачи. Со сводными таблицами знаком, в данном случае это неприменимо, потому что Лист2 имеет фиксированную разметку - это достаточно сложный отчет, который нужно заполнить цифрами по одной кнопке, нажатой пользователем.
С функцией СУММЕСЛИМН тоже знаком, но если её использовать на этом объеме данных, перерасчет всей книги на шести ядрах core i5-8500 c 16GB памяти занимает почти 2 минуты, что также недопустимо, т.к. перерасчет будет запускаться на каждое редактирование, фильтрацию и т.п. (application.calculation =xlcalculationmanual не предлагать, противоречит прочим неозвученным условиям)
В общем, требуется именно макрос, который будет работать по кнопке, и по возможности "мгновенно". Накидайте пожалуйста идей или ссылок на описание, какой алгоритм суммирования по нескольким условиям самый быстрый. С реализацией в VBA буду разбираться сам. Спасибо.
перед обработкой данных отключаем обработку событий Эксел Application.EnableEvents = False выполняем свои макросы потом включаем обработку событий Эксел Application.EnableEvents = True
sokol92 написал: Лучше данные накапливать в словаре , ключ словаря - конкатенация даты и ID (через какой-нибудь символ).
\ Это сильно ускорит исбавив от второго цикла, пусть даже и маленького 2. Не понятно что у вас там по критериям выбирается, но возможно SQL запрос сделает все без словарей и прочего. Связать две таблички по двум полям и взять нужные столбцы не сложно. Тоже можно и через PQ а не SQL. 3.
Для накопления/хранения/обработки данных предназначены СУБД, в простейшем случае excel, SQL можно применять и там и там, словари - специфическая вещь. Для начала попробуйте в excel PQ и ADO.
еще попробуйте отключать обновление экрана на время обработки: Application.ScreenUpdating = False Ваш код Включаем обновление экрана: Application.ScreenUpdating =True
LAD похож на бота с довольно бестолковыми советами
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
LAD: Судя по тому, как на меня окрысились некоторые модераторы и некоторые пользователи в моих советах есть дельные предложения.
с точностью, но наоборот
Цитата
LAD: еще попробуйте отключать обновление экрана на время обработки:
такой совет (и прочие ваши замечания) говорит о том, что вы не понимаете, для чего это нужно. Обновление экрана имеет смысл отключать при ПОСТОЯННОЙ (в цикле, например) выгрузке на лист. Также, оно НЕМНОГО помогает (больше психологически) при ПЕРЕКЛЮЧЕНИИ между листами в коде (что уже говорит, скорее, о плохом качестве кода). Если мы берём данные с листа, считаем всё в памяти и выгружаем обратно, то отключение экрана либо совсем не нужно, либо нужно только для непосредственно выгрузки.
вот это просто бомба. Применить функцию листа в коде VBA — это как примотать гири к ногам, в большинстве случаев.
LAD, короче говоря. Предвзятости нет, но псевдознатоков (а пока вы себя показали именно так) лично я очень не люблю — вы даёте некорректные советы и это вредит вопрошающим и форуму.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Option Explicit
Private Const source_sheet = "Лист1"
Private Const target_sheet = "Лист2"
Private Const source_first_row = 2
Private Const target_first_row = 2
Private Const source_key_column1 = 1
Private Const source_key_column2 = 2
Private Const source_sum_column = 3
Private Const target_key_column1 = 1
Private Const target_key_column2 = 2
Private Const target_sum_column = 3
Sub mySum()
Dim dic As Object
Set dic = GetMainDic()
If dic Is Nothing Then Exit Sub
PrintDic dic
End Sub
Private Sub PrintDic(dic As Object)
Const buf_size = 20000
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
Set sh = Sheets(target_sheet)
With sh
Dim r1 As Range: Set r1 = .Cells(target_first_row, target_key_column1)
Dim r2 As Range: Set r2 = .Cells(target_first_row, target_key_column2)
Dim rs As Range: Set rs = .Cells(target_first_row, target_sum_column)
Dim ya As Long
Dim arr As Variant
Dim brr As Variant
Dim crr As Variant
Dim bic As Object
Dim iKey1 As Long
Dim iKey2 As Long
Dim key1 As Variant
Dim key2 As Variant
For iKey1 = 0 To dic.Count - 1
key1 = dic.Keys()(iKey1)
Set bic = dic.Items()(iKey1)
For iKey2 = 0 To bic.Count - 1
key2 = bic.Keys()(iKey2)
If IsEmpty(arr) Then
If r1.Row + buf_size - 1 <= .Rows.Count Then
ReDim arr(1 To buf_size, 1 To 1)
Else
ReDim arr(1 To .Rows.Count - r1.Row + 1, 1 To 1)
End If
brr = arr
crr = arr
ya = 0
End If
ya = ya + 1
arr(ya, 1) = key1
brr(ya, 1) = key2
crr(ya, 1) = bic.Items()(iKey2)
If ya = UBound(arr, 1) Then
r1.Resize(UBound(arr, 1)).Value = arr
arr = Empty
r2.Resize(UBound(brr, 1)).Value = brr
brr = Empty
rs.Resize(UBound(crr, 1)).Value = crr
If r1.Row + buf_size <= .Rows.Count Then
Set r1 = r1.Cells(1 + buf_size)
Set r2 = r2.Cells(1 + buf_size)
Set rs = rs.Cells(1 + buf_size)
Else
Exit Sub
End If
crr = Empty
End If
Next
Next
End With
r1.Resize(UBound(arr, 1)).Value = arr
arr = Empty
r2.Resize(UBound(brr, 1)).Value = brr
brr = Empty
rs.Resize(UBound(crr, 1)).Value = crr
crr = Empty
Application.Calculation = Application_Calculation
End Sub
Private Function GetMainDic() As Object
Dim sh As Worksheet
Set sh = Sheets(source_sheet)
With sh
Dim yy As Long
yy = .Cells(.Rows.Count, source_key_column1).End(xlUp).Row
If yy <= source_first_row Then Exit Function
Dim arr As Variant
Dim brr As Variant
Dim crr As Variant
arr = .Cells(1, source_key_column1).Resize(yy).Value
brr = .Cells(1, source_key_column2).Resize(yy).Value
crr = .Cells(1, source_sum_column).Resize(yy).Value
End With
Dim bic As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim ya As Long
For ya = source_first_row To UBound(arr, 1)
If IsNumeric(crr(ya, 1)) Then
If ya = source_first_row Then
Set bic = CreateObject("Scripting.Dictionary")
Else
If arr(ya, 1) <> arr(ya - 1, 1) Then
If Not dic.Exists(arr(ya, 1)) Then
Set bic = CreateObject("Scripting.Dictionary")
Else
Set bic = dic.Item(arr(ya, 1))
End If
End If
End If
bic.Item(brr(ya, 1)) = bic.Item(brr(ya, 1)) + crr(ya, 1)
If ya = UBound(arr, 1) Then
Set dic.Item(arr(ya, 1)) = bic
Set bic = Nothing
ElseIf arr(ya, 1) <> arr(ya + 1, 1) Then
Set dic.Item(arr(ya, 1)) = bic
Set bic = Nothing
End If
End If
Next
Set GetMainDic = dic
End Function
да уж sokol92 уже дал главный совет. Теперь дело за ТСом. Это практически хрестоматийный пример бесспорного преимущества словарей, поскольку
Цитата
БМВ: Это сильно ускорит, избавив от второго цикла, пусть даже и маленького
Конечно, если заморочиться с альтернативами, то можно и бинарный поиск прикрутить и поиск инстром по длинной строке-сцепке, но суть тут одна — уйти от второго цикла.
UPD2: Ссылка на описание словарей с примерами и объяснениями. sokol92 дал ссылку на официальную страничку, а её (лично мне) гораздо тяжелее воспринимать
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
МатросНаЗебре, то, что ты говоришь — логично. Сумеет ли человек, не умеющий в логику, понять логичную конструкцию — вот главный вопрос. Философский немного…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
LAD, если вы считаете что ваши советы помогут ТСу, то можете оставаться при своем мнении. Это не первая тема с вашими советами которые имеют весьма поверхностный характер решений. А сообщения ради счетчика сообщений - точно лишние
Вариант с одноуровневым словарём - в качестве ключей используются значения двух столбцов, соединённые через разделитель. Интересно, словарь словарей работает в 1.5 раза быстрее. Вывод: словарь словарей - быстрее просто словарь - понятнее.
Скрытый текст
Код
Option Explicit
Sub mySum_OneDic()
Dim dic As Object
Set dic = GetMainDic()
If dic Is Nothing Then Exit Sub
PrintDic dic
End Sub
Sub CompareTime()
Dim dt As Date
dt = Now
mySum_DicOfDic
Debug.Print Format(Now - dt, "ss")
dt = Now
mySum_OneDic
Debug.Print Format(Now - dt, "ss")
End Sub
Private Sub PrintDic(dic As Object)
Const buf_size = 20000
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
Set sh = Sheets(target_sheet)
With sh
Dim r1 As Range: Set r1 = .Cells(target_first_row, target_key_column1)
Dim r2 As Range: Set r2 = .Cells(target_first_row, target_key_column2)
Dim rs As Range: Set rs = .Cells(target_first_row, target_sum_column)
Dim ya As Long
Dim arr As Variant
Dim brr As Variant
Dim crr As Variant
Dim krr As Variant
Dim srr As Variant
Dim trr As Variant
krr = dic.Keys()
srr = dic.Items()
Set dic = Nothing
ReDim arr(1 To UBound(krr) + 1, 1 To 1)
brr = arr
crr = arr
For ya = 1 To UBound(arr, 1)
trr = Split(krr(ya - 1), "#")
arr(ya, 1) = trr(0)
brr(ya, 1) = trr(1)
crr(ya, 1) = srr(ya - 1)
DoEvents
Next
End With
r1.Resize(UBound(arr, 1)).Value = arr
arr = Empty
r2.Resize(UBound(brr, 1)).Value = brr
brr = Empty
rs.Resize(UBound(crr, 1)).Value = crr
crr = Empty
Application.Calculation = Application_Calculation
End Sub
Private Function GetMainDic() As Object
Dim sh As Worksheet
Set sh = Sheets(source_sheet)
With sh
Dim yy As Long
yy = .Cells(.Rows.Count, source_key_column1).End(xlUp).Row
If yy <= source_first_row Then Exit Function
Dim arr As Variant
Dim brr As Variant
Dim crr As Variant
arr = .Cells(1, source_key_column1).Resize(yy).Value
brr = .Cells(1, source_key_column2).Resize(yy).Value
crr = .Cells(1, source_sum_column).Resize(yy).Value
End With
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim sKey As String
Dim ya As Long
For ya = source_first_row To UBound(arr, 1)
If IsNumeric(crr(ya, 1)) Then
sKey = myKey(arr(ya, 1), brr(ya, 1))
dic.Item(sKey) = dic.Item(sKey) + crr(ya, 1)
End If
Next
Set GetMainDic = dic
End Function
Private Function myKey(v1 As Variant, v2 As Variant)
myKey = v1 & "#" & v2
End Function
МатросНаЗебре: Интересно, словарь словарей работает в 1.5 раза быстрее.
сколько ключей в одноуровневом словаре? 100к и более? Близко к этому?
Учитывая, что и ID и дата — это целые числа, можно вообще без словарей, на массивах сделать (у массивов ключ — это индекс, то есть ID или дата). Это был бы самый быстрый вариант. И [практически] без ограничений по количеству элементов. Можно микс — массив словарей (Dim a() As Dictionary) или словарь с массивами в качестве элементов.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
пф. Ну так я ж давно уже рассказываю, что около 100к и далее начинаются торомоза. Ничего нового … Обходится массивом (не словарём) словарей или суперсловарями от BedVit'а.
правильно. Нужно найти минимальную и максимальную даты/ID и задать по ним массив. Или задать от 1 и использовать переменную для смещения, что не так удобно и немного (незаметно) медленнее.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
На моём тестовом наборе 1 млн строк, 300 тыс уникальных, не хватило памяти под вариант с массивами. По всей видимости, вариант с массивами будет быстрым, но сильно зависит от входных данных. При большом количестве повторов работать будет, а при большом количестве уникальных может упереться в ресурсы.
МатросНаЗебре: На моём тестовом наборе 1 млн строк, 300 тыс уникальных, не хватило памяти под вариант с массивами.
я ни за что не поверю, что 300к ключей влезают в словарь, но не влезают в массив Обратная ситуация — возможна.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
МатросНаЗебре, 20 тыс * 90 тыс это меньше 2 млрд. Что-то тут не так. Массив такого же размера, но от 1 — даёт создать? Может, ты забыл память очистить и что-то в глобальных/статических переменных висит? Тип массива должен быть Double.
UPD: у меня тоже не влезает))) максимум — 10к * 50к. Сейчас опишу альтернативный алгоритм — щадящий к памяти, но медленнее, конечно (не прям сильно).
UPD2: Получается сложно. Я бы просто массив словарей использовал или суперсловари от Виталия. Если суперсловари то всё просто: ключ = ID & "•" & Date, значение = копим сумму.
Если массив словарей (Dim aDic() As Dictionary), то 2 варианта: • не факт, что хватит памяти: в массиве столько элементов, сколько уникальных дат (ReDim aDic (45292 to 62523) ). По дате/числу мы получаем словарь с парами "ID (для этой даты) — сумма". Далее, копим, как обычно. • оптимальный по памяти: в массиве столько элементов/словарей, чтобы в каждом из них было не более 100 тыс элементов (лучше 80). То есть, если уникальных комбинаций 300к, то будет 3 или 4 элемента в массиве. Далее алгоритм тот же, что и суперсловарей, только мы последовательно проверяем каждый словарь, пока не найдём нужный ключ.
Сразу видно, насколько суперсловари удобнее
При желании, можно оптимизировать 2ой вариант — чтобы точно знать, где искать. Например, в 1ом словаре будут даты или ID с N1 по N2 и так далее … Для того, чтобы в динамике понимать, в каком словаре, какой диапазон дат — можно завести отдельный одномерный Long-массив.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄