Доброго всем времени суток! Нужен коллективный разум - стрелкам осциллографа не беспокоится... Массивы в памяти обрабатываются быстро - но вот с выводом беда Можно ли, каким либо образом поправить положение - ускорить вывод данных?
Какие есть идеи, предложения, думы, способы и механизмы?
Код
'1)время обработки данных
T1 = Timer
T3 = T1 - t
' 2)вывод на лист
Application.ScreenUpdating = False 'Выключаем обновление экрана'
MsgBox "Обработка данных - " & T3 & "cek"
With Sheets("Sheet1")
' Set Cel = .Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Cells(6, 1).Resize(K, Col).Value = Result ' Вывод данных из массива на лист
End With
Application.ScreenUpdating = True 'Выключаем обновление экрана'
T2 = Timer - T1
' информация о времени работы.
MsgBox "Вывод на лист - " & T2 & "cek" & Chr(10) , , "Проверка на скорость"
Гонял на такой конфигурации - Win7 32, ОЗУ 4гб, Xeon E5450 3.40 ГГЦ, видяха GTS 250 1 Гб шина 256 bit 3 раза запускал алгоритм на 100 000 строк. Расчетная часть отрабатывает за 3.8 сек - тут проблем нет. Но вот с выводом данных на экран беда - лопатит больше 20 мин., ни разу не дождался...))) Причем система загружена на 25 процентов всего, Excel в ОЗУ занимает 800 Мб... Решил спуститься пониже - на 50 000 строк. Расчетная часть отработала за 2.01 сек - нормально. Вывод данных - 1094 сек
Сейчас прогнал на более мощном. Конфигурация такая -Win10 64, OЗУ 8гб, i5-7500 3.4 ГГЦ, видяха встроенная HD Graphics 630. на 10 000строк - обработка данных - 0,218 сек, вывод данных - 17 сек на 50 000 строк - обработка данных - 1 сек., вывод данных на экран - 660 сек. на 100 000 строк - обработка данных-2,01 сек, вывод данных на экран - 2435 сек. То есть обработка на высоте, с выводом беда. Обработка данных - зависимость просто линейная. Вывод данных - прямо таки настоящая экспонента...))) Вот как то вот так...)))
Application.ScreenUpdating = False 'Выключаем обновление экрана'
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
With Sheets("Sheet1")
.Cells(6, 1).Resize(K, Col).Value = Result ' Вывод результирующего массива на лист
End With
Application.ScreenUpdating = True 'Выключаем обновление экрана'
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Товарищи -руль покрутил, по колесу постучал, стекло протер... Но каменная чаша так и не вышла...))) Лист, на который идет вывод - чистейший, именованных диапазонов нет, ни формул ни форматирования нет. Может есть не очень традиционные методы борьбы???
Ячеек вставляется много - 200 000 х 47... Но не полчаса же их вставлять...)))
Джек Восмеркин написал: Но не полчаса же их вставлять...)))
смотря какую цель Вы преследуете если нужно показать заказчику, какой мощный макрос Вы написали и как он тужится над расчетами заполняя данными 200тыс х 47 ячеек можно и полчаса... (я обычно в это время стою рядом и важно надуваю щеки, чтобы придать значимости всему происходящему)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
ну и ко всем прочим замечаниям: зачем отдельные переменные для ресайза, если можно ресайзить точно по границам массива??? Sheets("Sheet1").Cells(6, 1).Resize(UBound(Result,1), UBound(Result,2)).Value = Result
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
vikttur, я это знаю))) и это, наверное, единственный логически обоснованный вариант. Однако, если человек создаёт тему "Как ускорить вывод данных из массива на лист" (когда это одна операция и можно её только "замедлить", выводя в цикле), то хотелось бы узнать его версию
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
зато есть Worksheet_Activate — без неё выводит мгновенно
В модуле листа «Sheet 1» (на который выводится)
Код
Private Sub CommandButton3_Click()
UsedRange.Offset(5).EntireRow.Delete ' удаляем ранее заполненные строки;
Call CollectingSheets
End Sub
Private Sub Worksheet_Activate()
UsedRange.Offset(5).EntireRow.Delete ' удаляем ранее заполненные строки;
End Sub
Исполнительный макрос
Код
Option Explicit
Sub CollectingSheets()
Dim t, T1, T2, T3: t = Timer ' для подсчета времени работы
Dim i&, j&, R&, C, Col&, Result(), UsAr(), ResAr(), PkAr()
Dim IdDict As Object, USDict As Object, Head(), a
Dim RN As Range, Cel As Range, Rn1 As Range, K&, L&
Set IdDict = CreateObject("Scripting.Dictionary") ' словарь ID Отвтственных
Set USDict = CreateObject("Scripting.Dictionary") ' словарь ID пользователей
' Лист PC
With Worksheets("PC")
' последняя строка (по первому столбцу)
R = .Cells(Rows.Count, 1).End(xlUp).Row
' последний столбец( по первой строке)
C = .Cells(1, Columns.Count).End(xlToLeft).Column 'количество столбцов
' Берем в массив данные
PkAr = .Range("A2", .Cells(R, C)).Value
' строка заголовков, ссылка
Set RN = .Range(.Cells(1, 1), .Cells(1, C))
End With
' лист Sheet1, заголовки
With Worksheets("Sheet1")
Col = .Cells(5, Columns.Count).End(xlToLeft).Column 'количество столбцов в пятой стрке
' ссылка на 5-ю строку
Set Rn1 = .Range(.Cells(5, 1), .Cells(5, Col))
With CreateObject("Scripting.Dictionary")
For Each Cel In RN
' создаем словарь - заголовки PC и в каких столбцах
.Item(Cel.Value) = Cel.Column
Next Cel
' создаем массив соответствия заголовков Sheet1 и PC
ReDim Head(1, 1 To Rn1.Count)
For i = 1 To Rn1.Count
If .exists(Rn1(i).Value) Then
Head(0, i) = i
Head(1, i) = .Item(Rn1(i).Value)
Else
Head(0, i) = ""
Head(1, i) = ""
End If
'Head(0, 12) = ""
'Head(1, 12) = ""
Head(0, 13) = ""
Head(1, 13) = ""
Head(0, 27) = ""
Head(1, 27) = ""
Next i
End With
End With
ReDim Result(1 To 300000, 1 To Col)
With Worksheets("User")
R = .Cells(Rows.Count, 1).End(xlUp).Row
C = .Cells(1, Columns.Count).End(xlToLeft).Column 'количество столбцов
UsAr = .Range("A2", .Cells(R, C)).Value
' словарь Container_Unique_Id User
For i = 1 To UBound(UsAr)
USDict(UsAr(i, 1)) = UsAr(i, 2)
Next
End With
With Worksheets("User1")
R = .Cells(Rows.Count, 1).End(xlUp).Row
C = .Cells(1, Columns.Count).End(xlToLeft).Column 'количество столбцов
ResAr = .Range("A2", .Cells(R, C)).Value
With IdDict
For i = 1 To UBound(ResAr)
' словарь Container_Unique_Id User1
If .exists(ResAr(i, 1)) Then
' если User1 несколько - собираем их в одну запись
.Item(ResAr(i, 1)) = .Item(ResAr(i, 1)) & "#" & ResAr(i, 2)
Else
.Item(ResAr(i, 1)) = ResAr(i, 2)
End If
Next
End With
End With
K = 0 ' № строки массива результата
' сборка результата в моассив
For i = 1 To UBound(PkAr)
If IdDict.exists(PkAr(i, 1)) Then
a = Split(IdDict(PkAr(i, 1)), "#")
For L = 0 To UBound(a)
K = K + 1
For j = 1 To Col
If IsNumeric(Head(0, j)) Then
Result(K, j) = PkAr(i, Head(1, j))
End If
Next j
'Result(K, 12) = USDict(PkAr(i, 1))
Result(K, 13) = USDict(PkAr(i, 1))
Result(K, 27) = a(L)
Next L
Else
K = K + 1
For j = 1 To Col
If IsNumeric(Head(0, j)) Then
Result(K, j) = PkAr(i, Head(1, j))
End If
Next j
End If
Next i
' время обработки данных
T1 = Timer
T3 = T1 - t
MsgBox "Обработка данных - " & T3 & "cek" & Chr(10)
' вывод на лист
Application.ScreenUpdating = False 'Выключаем обновление экрана'
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
With Sheets("Sheet1")
.Cells(6, 1).Resize(K, Col).Value = Result ' Вывод результирующего массива на лист
End With
Application.ScreenUpdating = True 'Выключаем обновление экрана'
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
T2 = Timer - T1
' информация о времени работы.
MsgBox "Вывод на лист - " & T2 & "cek" & Chr(10) & "всего - " & T3 + T2
End Sub
коды привёл, чтобы остальным можно было тут посмотреть и не лезть в файл
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Убрал Worksheet_Activate() и в кнопке - UsedRange.Offset(5).EntireRow.Delete Прогнал. Входной массив - 110 000 строк. Выходной массив - 220 000 строк, 47 столбцов.... Обработка данных - 4.27 сек Вывод данных - 1671 сек. Ускорение примерно в 2 раза
Можно еще снизить время вывода?
Великий и могучий утес, сверкающий бой, с ногой на небе, живущий, пока не исчезнут машины.
Sub qq()
Dim ar(1 To 200000, 1 To 47), t!, i&, j&
For i = 1 To 200000
For j = 1 To 47
ar(i, j) = Rnd
Next
Next
t = Timer
[a1].Resize(UBound(ar), UBound(ar, 2)).Value = ar
Debug.Print Format(Timer - t, "0.0000")
End Sub
41 сек Комп 2 ядра, 32 система PS на момент выполнения занято 70% памяти
RAN, Андрей, не позорь зверей :-) , в одном случае только числа в другом текст, и это не 10 байтов. :-) Очень неловко медведю по ушам Макрушникам ездить, собственно дело тут не в макросах, 100к строк - результат в оригинальном файле ужасен, устал ждать и даже не записал, а вот после изменения внесенного Обработка данных - 4,953125cek Вывод на лист - 17cek всего - 21,95313 Изменил только формат ячеек на листе Sheet1, убрав Wrap Text. Думаю понятно сколько ресурсов бедняге было надо почти все эти строки обработать и расширить по высоте.
- была у меня законная Windows 10 Insider Preview - но рухнула без возможности восстановления, уж не знаю что там понаобновлялось... Отформатировал диск и вернулся на семёрку.