Очень нужна Ваша помощь в создании макроса, который будет обрабатывать большие данные и производить все расчеты в памяти, а не на листах.
Вводные данные: Имеется файл с кучей закладок (около 800) На каждой из закладок есть несколько колонок с формулами. Как понимаете, при обновлеии файла, калькуляция занимает до 20 минут что очень долго... Знаю, что данные можно закинуть в память эксель и произвести все расчеты там. А на листы уже вписать значения без формул. Но знаний не хватает сделать это.. Кто может помочь?
Приаттачил файл, но оставил там только несколько закладок, чтобы было попроще работать с файлом :-) Заранее спасибо за помощь и подсказки!
Уважаемые гуру VBA!
Очень нужна Ваша помощь в создании макроса, который будет обрабатывать большие данные и производить все расчеты в памяти, а не на листах.
Вводные данные: Имеется файл с кучей закладок (около 800) На каждой из закладок есть несколько колонок с формулами. Как понимаете, при обновлеии файла, калькуляция занимает до 20 минут что очень долго... Знаю, что данные можно закинуть в память эксель и произвести все расчеты там. А на листы уже вписать значения без формул. Но знаний не хватает сделать это.. Кто может помочь?
Приаттачил файл, но оставил там только несколько закладок, чтобы было попроще работать с файлом :-) Заранее спасибо за помощь и подсказки!IvanK710
Добавил в файл вот этот код, который закидывает данные в память. Подскажите, все правильно? Как мне теперь вытащить из него необходимые данные? :-)
[vba]
Код
Sub Test001()
Dim B As New Collection LastRow = Range("A2").End(xlDown).Row 'last colomun calculation For i = 3 To LastRow Dim A As New Data1 A.Number = Sheet_Data1.Range("A2") A.Date_ = Sheet_Data1.Range("C2") A.Parametr = Sheet_Data1.Range("B2") A.Quantity = Sheet_Data1.Range("D2") B.Add A Set A = Nothing Next i i = 1
End Sub
[/vba]
Добавил в файл вот этот код, который закидывает данные в память. Подскажите, все правильно? Как мне теперь вытащить из него необходимые данные? :-)
[vba]
Код
Sub Test001()
Dim B As New Collection LastRow = Range("A2").End(xlDown).Row 'last colomun calculation For i = 3 To LastRow Dim A As New Data1 A.Number = Sheet_Data1.Range("A2") A.Date_ = Sheet_Data1.Range("C2") A.Parametr = Sheet_Data1.Range("B2") A.Quantity = Sheet_Data1.Range("D2") B.Add A Set A = Nothing Next i i = 1
'Просчет минимумов For i = 1 To UBound(arr) If dic.exists(arr(i, 1)) Then t = dic(arr(i, 1)) Else t = 9 ^ 9 dic(arr(i, 1)) = Application.WorksheetFunction.Min(t, arr(i, 3)) Next
'Заполнение итогового массива ReDim arrN(1 To UBound(arr), 1 To 1) For i = 1 To UBound(arr) arrN(i, 1) = dic(arr(i, 1)) Next 'Достаем из "памяти" на лист Range("f2").Resize(UBound(arrN)) = arrN
'Просчет минимумов For i = 1 To UBound(arr) If dic.exists(arr(i, 1)) Then t = dic(arr(i, 1)) Else t = 9 ^ 9 dic(arr(i, 1)) = Application.WorksheetFunction.Min(t, arr(i, 3)) Next
'Заполнение итогового массива ReDim arrN(1 To UBound(arr), 1 To 1) For i = 1 To UBound(arr) arrN(i, 1) = dic(arr(i, 1)) Next 'Достаем из "памяти" на лист Range("f2").Resize(UBound(arrN)) = arrN
Ваша вторая формула - в корни отличается от первой. В Вашем случае - легче использовать Evaluate - он позволяет делать расчеты разными формулами внутри макроса: [vba]
Код
Sub DD() Dim lastrow&, arr, i&, arrN With Sheets("5555") lastrow = .Range("A2").End(xlDown).Row 'last colomun calculation 'Добавляем Массив в "память" arr = .Range("A3:d" & lastrow) 'Заполнение итогового массива ReDim arrN(1 To UBound(arr), 1 To 1) For i = 1 To UBound(arr) arrN(i, 1) = Evaluate("=SUMIFS(Data1!D:D,Data1!A:A," & .[a1] & ",Data1!C:C," & CDbl(arr(i, 1)) & ",Data1!B:B,""Min"")") Next .Range("f3").Resize(UBound(arrN)) = arrN End With End Sub
[/vba] Остальные формулы - сами старайтесь подогнать. Обратите внимание на этот кусок: [vba]
Код
CDbl(arr(i, 1)) '- перевод дат в число
[/vba]
Добавлено Упустил из вида, что загвоздка в скорости. Ладно, поскольку уже сам ответил - сделал на массивах (см. файл 2): [vba]
Код
Sub Ddd() Dim lastrow&, arr, Marr, dic As Object, i&, t#, arrN
Set dic = CreateObject("Scripting.dictionary")
With Sheets("Data1") lastrow = .Range("A2").End(xlDown).Row 'last colomun calculation 'Добавляем Массив в "память" arr = .Range("A2:d" & lastrow) End With
'Просчет Суммы For i = 1 To UBound(arr) If dic.exists(arr(i, 1) & arr(i, 2) & arr(i, 3)) Then dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) = dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) + arr(i, 4) Else dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) = arr(i, 4) End If If i \ 100 = i / 100 Then DoEvents: Application.StatusBar = "Calculate sum: " & i & ": " & Format(i / UBound(arr), "0%") Next
'Заполнение итогового массива With Sheets("5555") lastrow = .Range("A2").End(xlDown).Row 'last colomun calculation 'Добавляем Массив в "память" arr = .Range("A3:d" & lastrow) 'Заполнение итогового массива ReDim arrN(1 To UBound(arr), 1 To 1) For i = 1 To UBound(arr) If dic.exists(.[a1] & "Min" & arr(i, 1)) Then arrN(i, 1) = dic(.[a1] & "Min" & arr(i, 1)) If i \ 100 = i / 100 Then DoEvents: Application.StatusBar = "Calculate FinArray: " & i & ": " & Format(i / UBound(arr), "0%") Next .Range("e3").Resize(UBound(arrN)) = arrN End With
Application.StatusBar = False End Sub
[/vba] Но все Ваши остальные формулы или сами переводите, или отдельными темами, с указанием формулы хотите перевести в массивы...
Ваша вторая формула - в корни отличается от первой. В Вашем случае - легче использовать Evaluate - он позволяет делать расчеты разными формулами внутри макроса: [vba]
Код
Sub DD() Dim lastrow&, arr, i&, arrN With Sheets("5555") lastrow = .Range("A2").End(xlDown).Row 'last colomun calculation 'Добавляем Массив в "память" arr = .Range("A3:d" & lastrow) 'Заполнение итогового массива ReDim arrN(1 To UBound(arr), 1 To 1) For i = 1 To UBound(arr) arrN(i, 1) = Evaluate("=SUMIFS(Data1!D:D,Data1!A:A," & .[a1] & ",Data1!C:C," & CDbl(arr(i, 1)) & ",Data1!B:B,""Min"")") Next .Range("f3").Resize(UBound(arrN)) = arrN End With End Sub
[/vba] Остальные формулы - сами старайтесь подогнать. Обратите внимание на этот кусок: [vba]
Код
CDbl(arr(i, 1)) '- перевод дат в число
[/vba]
Добавлено Упустил из вида, что загвоздка в скорости. Ладно, поскольку уже сам ответил - сделал на массивах (см. файл 2): [vba]
Код
Sub Ddd() Dim lastrow&, arr, Marr, dic As Object, i&, t#, arrN
Set dic = CreateObject("Scripting.dictionary")
With Sheets("Data1") lastrow = .Range("A2").End(xlDown).Row 'last colomun calculation 'Добавляем Массив в "память" arr = .Range("A2:d" & lastrow) End With
'Просчет Суммы For i = 1 To UBound(arr) If dic.exists(arr(i, 1) & arr(i, 2) & arr(i, 3)) Then dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) = dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) + arr(i, 4) Else dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) = arr(i, 4) End If If i \ 100 = i / 100 Then DoEvents: Application.StatusBar = "Calculate sum: " & i & ": " & Format(i / UBound(arr), "0%") Next
'Заполнение итогового массива With Sheets("5555") lastrow = .Range("A2").End(xlDown).Row 'last colomun calculation 'Добавляем Массив в "память" arr = .Range("A3:d" & lastrow) 'Заполнение итогового массива ReDim arrN(1 To UBound(arr), 1 To 1) For i = 1 To UBound(arr) If dic.exists(.[a1] & "Min" & arr(i, 1)) Then arrN(i, 1) = dic(.[a1] & "Min" & arr(i, 1)) If i \ 100 = i / 100 Then DoEvents: Application.StatusBar = "Calculate FinArray: " & i & ": " & Format(i / UBound(arr), "0%") Next .Range("e3").Resize(UBound(arrN)) = arrN End With
Application.StatusBar = False End Sub
[/vba] Но все Ваши остальные формулы или сами переводите, или отдельными темами, с указанием формулы хотите перевести в массивы...SLAVICK
SLAVICK, спасибо Вам огромное за помощь! Вы мне очень помогли (как и многим на этом форуме, судя по репутации в профиле), сейчас буду применять Ваш код на большом файле, отпишусь о результатах.
SLAVICK, спасибо Вам огромное за помощь! Вы мне очень помогли (как и многим на этом форуме, судя по репутации в профиле), сейчас буду применять Ваш код на большом файле, отпишусь о результатах.IvanK710
Сообщение отредактировал IvanK710 - Среда, 07.03.2018, 12:33