Всем доброго времени !!!!! Продолжаются попытки хоть как то уменьшить размер и увеличить скорость работы моих огромных файлов.В свете этого была предпринята попытка написать макрос вставки формул в ячейки, копирования и вставки значений с последующим уничтожением нулей(спасибо Ярославу за макрос).Получился вот такой вот монстр ъ
[vba]
Код
Sub СУММПР_1() Dim lLastRow As Long Dim lLastCol As Long
Sheets("состав").Range("B30").FormulaLocal = "=СУММПРОИЗВ(План!$GB$19:$GB$1000*(План!$C$19:$C$1000=состав!B$31))" 'вставляем формулу в 30 строку Range("B30").Select Application.CutCopyMode = False Selection.AutoFill Destination:=Range(Cells(30, 2), Cells(30, lLastCol)), Type:=xlFillDefault 'копируем на весь диапазон Range(Cells(30, 2), Cells(30, lLastCol)).Select Selection.Copy ' копируем Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'вставляем значения
Dim sh As Worksheet, r As Range If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава) For Each sh In ActiveWindow.SelectedSheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next Else If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection r.Replace 0, "", xlWhole Else For Each sh In ActiveWorkbook.Sheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next End If End If End Sub
[/vba]
вполне рабочий, но на моих объемах очень медленный. Можно его как то ускорить?
Всем доброго времени !!!!! Продолжаются попытки хоть как то уменьшить размер и увеличить скорость работы моих огромных файлов.В свете этого была предпринята попытка написать макрос вставки формул в ячейки, копирования и вставки значений с последующим уничтожением нулей(спасибо Ярославу за макрос).Получился вот такой вот монстр ъ
[vba]
Код
Sub СУММПР_1() Dim lLastRow As Long Dim lLastCol As Long
Sheets("состав").Range("B30").FormulaLocal = "=СУММПРОИЗВ(План!$GB$19:$GB$1000*(План!$C$19:$C$1000=состав!B$31))" 'вставляем формулу в 30 строку Range("B30").Select Application.CutCopyMode = False Selection.AutoFill Destination:=Range(Cells(30, 2), Cells(30, lLastCol)), Type:=xlFillDefault 'копируем на весь диапазон Range(Cells(30, 2), Cells(30, lLastCol)).Select Selection.Copy ' копируем Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'вставляем значения
Dim sh As Worksheet, r As Range If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава) For Each sh In ActiveWindow.SelectedSheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next Else If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection r.Replace 0, "", xlWhole Else For Each sh In ActiveWorkbook.Sheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next End If End If End Sub
[/vba]
вполне рабочий, но на моих объемах очень медленный. Можно его как то ускорить?китин
Боюсь надоесть всем своими "советами", но ! У Вас много данных и много вычислений. Кардинально (на порядки) скорость можно увеличить, поместив все данные в БД Access и все вычисления проводить там запросами. Еще лучше SQL Server+StorageProc Все вычисления и отображения данных (если заполнения ячеек делать массивами) будут выполняться мгновенно !
Боюсь надоесть всем своими "советами", но ! У Вас много данных и много вычислений. Кардинально (на порядки) скорость можно увеличить, поместив все данные в БД Access и все вычисления проводить там запросами. Еще лучше SQL Server+StorageProc Все вычисления и отображения данных (если заполнения ячеек делать массивами) будут выполняться мгновенно !SGerman
Мудрость приходит со старостью. Но иногда старость приходит одна :)
Игорь, попробуйте так (массивы вместо формул и куча циклов): [vba]
Код
Sub СУММПР_2() ' t = Timer Dim lLastRow As Long
Dim lLastCol As Long Dim data, result, lr As Long, i As Long, j As Long, k As Long, d As Long Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = ThisWorkbook.Sheets("План") Set sh2 = ThisWorkbook.Sheets("состав") lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column With sh2 .Range("B1:AG30").ClearContents lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row data = sh1.Range("a15:gb" & lr).Value ReDim result(UBound(data) - 1, UBound(data, 1) - 1)
For i = 4 To UBound(data) For j = 2 To 33 'по столбцам b31:ag31 If data(i, 3) = .Cells(31, j) Then 'Вместо формулы для 1-й строки result(0, j - 2) = result(0, j - 2) + data(i, 7) + data(i, 8) + data(i, 9) 'Вместо формул для диапазона b2:ag29 For d = 2 To 29 'по строкам с датами на листе состав For k = 16 To 183 'по столбцам $P$18:$GA$800 на листе план If data(2, k) = "СБ" And data(1, k) = .Cells(d, 1) Then result(d - 1, j - 2) = result(d - 1, j - 2) + data(i, k) End If Next k Next d 'Вместо формулы для 30-й строки result(29, j - 2) = result(29, j - 2) + data(i, 184) End If Next j Next i .Range("B1:AG30") = result End With 'Дальше ничего не трогала Dim sh As Worksheet, r As Range If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава) For Each sh In ActiveWindow.SelectedSheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next Else If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection r.Replace 0, "", xlWhole Else For Each sh In ActiveWorkbook.Sheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next End If End If ' Debug.Print Timer - t End Sub
[/vba]
Игорь, попробуйте так (массивы вместо формул и куча циклов): [vba]
Код
Sub СУММПР_2() ' t = Timer Dim lLastRow As Long
Dim lLastCol As Long Dim data, result, lr As Long, i As Long, j As Long, k As Long, d As Long Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = ThisWorkbook.Sheets("План") Set sh2 = ThisWorkbook.Sheets("состав") lLastCol = Cells(31, Columns.Count).End(xlToLeft).Column With sh2 .Range("B1:AG30").ClearContents lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row data = sh1.Range("a15:gb" & lr).Value ReDim result(UBound(data) - 1, UBound(data, 1) - 1)
For i = 4 To UBound(data) For j = 2 To 33 'по столбцам b31:ag31 If data(i, 3) = .Cells(31, j) Then 'Вместо формулы для 1-й строки result(0, j - 2) = result(0, j - 2) + data(i, 7) + data(i, 8) + data(i, 9) 'Вместо формул для диапазона b2:ag29 For d = 2 To 29 'по строкам с датами на листе состав For k = 16 To 183 'по столбцам $P$18:$GA$800 на листе план If data(2, k) = "СБ" And data(1, k) = .Cells(d, 1) Then result(d - 1, j - 2) = result(d - 1, j - 2) + data(i, k) End If Next k Next d 'Вместо формулы для 30-й строки result(29, j - 2) = result(29, j - 2) + data(i, 184) End If Next j Next i .Range("B1:AG30") = result End With 'Дальше ничего не трогала Dim sh As Worksheet, r As Range If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава) For Each sh In ActiveWindow.SelectedSheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next Else If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection r.Replace 0, "", xlWhole Else For Each sh In ActiveWorkbook.Sheets Set r = sh.UsedRange r.Replace 0, "", xlWhole Next End If End If ' Debug.Print Timer - t End Sub
Марина спасибо. немного быстрее. Но один маленький недостаток:В твоем коде с моим багажом(весьма скудным ) знаний я вряд ли разберусь, что бы подправить его хотя бы в количестве столбцов: их у меня сейчас 700 и будут добавляться.Я почему и сделал поиск по последнему столбцу[vba]
Марина спасибо. немного быстрее. Но один маленький недостаток:В твоем коде с моим багажом(весьма скудным ) знаний я вряд ли разберусь, что бы подправить его хотя бы в количестве столбцов: их у меня сейчас 700 и будут добавляться.Я почему и сделал поиск по последнему столбцу[vba]
With Range(Cells(2, 2), Cells(29, lLastCol)) .FormulaR1C1 = _ "=SUMPRODUCT(План!R18C16:R800C183*(План!R16C16:R16C183=""СБ"")*(План!R15C16:R15C183=состав!RC1)*(состав!R31C=План!R18C3:R800C3))" Debug.Print "2): " & Timer - t: t = Timer .Value = .Value Debug.Print "2): " & Timer - t: t = Timer ' .Copy ' .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'вставляем значения End With 'Debug.Print "2): " & Timer - t: t = Timer
Sheets("состав").Range("B30").FormulaLocal = "=СУММПРОИЗВ(План!$GB$19:$GB$1000*(План!$C$19:$C$1000=состав!B$31))" 'вставляем формулу в 30 строку Range("B30").Select Application.CutCopyMode = False Selection.AutoFill Destination:=Range(Cells(30, 2), Cells(30, lLastCol)), Type:=xlFillDefault 'копируем на весь диапазон Range(Cells(30, 2), Cells(30, lLastCol)).Select Selection.Copy ' копируем Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'вставляем значения
Debug.Print "3): " & Timer - t Debug.Print MsgBox "ok" ' Dim sh As Worksheet, r As Range ' If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава) ' For Each sh In ActiveWindow.SelectedSheets ' Set r = sh.UsedRange ' r.Replace 0, "", xlWhole ' Next ' Else ' If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then ' If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection ' r.Replace 0, "", xlWhole ' Else ' For Each sh In ActiveWorkbook.Sheets ' Set r = sh.UsedRange ' r.Replace 0, "", xlWhole ' Next ' End If ' End If End Sub
With Range(Cells(2, 2), Cells(29, lLastCol)) .FormulaR1C1 = _ "=SUMPRODUCT(План!R18C16:R800C183*(План!R16C16:R16C183=""СБ"")*(План!R15C16:R15C183=состав!RC1)*(состав!R31C=План!R18C3:R800C3))" Debug.Print "2): " & Timer - t: t = Timer .Value = .Value Debug.Print "2): " & Timer - t: t = Timer ' .Copy ' .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'вставляем значения End With 'Debug.Print "2): " & Timer - t: t = Timer
Sheets("состав").Range("B30").FormulaLocal = "=СУММПРОИЗВ(План!$GB$19:$GB$1000*(План!$C$19:$C$1000=состав!B$31))" 'вставляем формулу в 30 строку Range("B30").Select Application.CutCopyMode = False Selection.AutoFill Destination:=Range(Cells(30, 2), Cells(30, lLastCol)), Type:=xlFillDefault 'копируем на весь диапазон Range(Cells(30, 2), Cells(30, lLastCol)).Select Selection.Copy ' копируем Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'вставляем значения
Debug.Print "3): " & Timer - t Debug.Print MsgBox "ok" ' Dim sh As Worksheet, r As Range ' If ActiveWindow.SelectedSheets.Count > 1 Then 'убираем нули после спецвставка( код от Ярослава) ' For Each sh In ActiveWindow.SelectedSheets ' Set r = sh.UsedRange ' r.Replace 0, "", xlWhole ' Next ' Else ' If MsgBox("Заменить 0 во всей книге?", vbYesNo) = vbNo Then ' If Selection.Count = 1 Then Set r = ActiveSheet.UsedRange Else Set r = Selection ' r.Replace 0, "", xlWhole ' Else ' For Each sh In ActiveWorkbook.Sheets ' Set r = sh.UsedRange ' r.Replace 0, "", xlWhole ' Next ' End If ' End If End Sub
Ну наконец то добрался до тестирования. последний вариант отработал на УРА. мои объемы просчитал за 1,5 минуты. файл упал на 0,5 метра и больше не тормозит(почти). Огромное всем спасибо за помощь и терпение !!!
Ну наконец то добрался до тестирования. последний вариант отработал на УРА. мои объемы просчитал за 1,5 минуты. файл упал на 0,5 метра и больше не тормозит(почти). Огромное всем спасибо за помощь и терпение !!!китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
я имел ввиду замена там либо цифирок в рабочем диапазоне или полная замена этого диапазона путем вставки такой же таблицы, скопированной из другой книги
я имел ввиду замена там либо цифирок в рабочем диапазоне или полная замена этого диапазона путем вставки такой же таблицы, скопированной из другой книгикитин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Сообщение отредактировал китин - Среда, 03.08.2016, 13:22