Добрый день. Просьба помочь оптимизировать макрос. Есть файл, в котором несколько листов/сводных. В самом большом листе(в примере лист называться "Исх") будет около 80 тис. строчек(может быть и больше так как данные обновляются). Нужен макрос который исходный файл разделит на несколько файлов поменьше и перенесет в них только строки по определенному критерию. То есть в колонке J записаны названия города (в примере Винница, Днепр, Киев) нужно создать файлы Винница_сегодняшняя_дата, Днепр_сегодняшняя_дата и т.д. и чтобы в новом файле остались только строки в которых название файла соответствует значению колонки J.
Я в VBA можно сказать новичок, это мой второй макрос, прошу сильно не ругать если плохо написал. Вот что у мене получилось:
st = Timer Dim X As String strDate = Format(Now, "dd.mm") On Error Resume Next MkDir "C:\отчёт\август\" & strDate 'создать новую папку strPath = "C:\отчёт\август\" & strDate 'папка для сохранения книги On Error Resume Next X = GetAttr(strPath) And 0 If Err = 0 Then ' если путь существует - сохраняем книгу, добавляя дату Dim i As Integer LastCell1 = Sheets("Info").Range("A1").End(xlDown).Row 'For i = 2 To 3 For i = 2 To LastCell1 FileNameXls = strPath & "\" & Sheets("Info").Cells(i, 1).Value & " " & strDate & ".xlsx" 'создание копий файлов с именами из ячеек листа "Info" ActiveWorkbook.SaveCopyAs Filename:=FileNameXls Workbooks.Open Filename:=FileNameXls 'открыть созданый файл
Dim n As Integer Dim Podr As String Dim PodrNow As String PodrNow = Sheets("Info").Cells(i, 1).Value LastCell2 = Sheets("Исх").Range("J1").End(xlDown).Row For n = LastCell2 To 2 Step -1 Podr = Sheets("Исх").Cells(n, 10).Value If Podr <> PodrNow Then Sheets("Исх").Rows(n).Delete Next
Dim wsSh As Worksheet, PVTable As PivotTable 'обновление всех сводных For Each wsSh In Worksheets For Each PVTable In wsSh.PivotTables: PVTable.RefreshTable: Next PVTable Next wsSh
Workbooks(Sheets("Info").Cells(i, 1).Value & " " & strDate & ".xlsx").Close SaveChanges:=True 'SAVE AND CLOSE Next i Else 'если путь не существует - выводим сообщение MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical End If fsh = Timer MsgBox "Все ОК! Время работы макроса: " & (fsh - st) \ 60 & " мин. " & Round((fsh - st) - (((fsh - st) \ 60) * 60), 0) & " сек."
Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True End Sub
[/vba]
В двух словах о макросе. Даные о количистве файлов и их название макрос берет из листа "Info" количество названий будет всегда одинаково и меняться не будет. Для роботы макроса нужно на диске С иметь путь C:\отчёт\август\ (наверно можно сделать чтобы макрос создавал файлы в папке текущего рабочего файла, пока написал так, пока не критично).
С моими знаниями VBA я смог написать макрос который будет перебирать значение ячеек колонки J и удалять те которые не соответствуют критерию. Но этот метод очень долгий. Как оптимизировать не знаю.
[vba]
Код
Dim n As Integer Dim Podr As String Dim PodrNow As String PodrNow = Sheets("Info").Cells(i, 1).Value LastCell2 = Sheets("Исх").Range("J1").End(xlDown).Row For n = LastCell2 To 2 Step -1 Podr = Sheets("Исх").Cells(n, 10).Value If Podr <> PodrNow Then Sheets("Исх").Rows(n).Delete Next
[/vba]
Тестировал на файле из 13 тис строк. для создания одного файла требуется около 2 минут. Таких файлов нужно будет делать 25, исходник будет состоять из 80 тис строк. Думаю будет очеееень долго, а своими силами не знаю как изменить макрос чтоб работал шустрее.
Буду признателен за любой совет. Спасибо!
Добрый день. Просьба помочь оптимизировать макрос. Есть файл, в котором несколько листов/сводных. В самом большом листе(в примере лист называться "Исх") будет около 80 тис. строчек(может быть и больше так как данные обновляются). Нужен макрос который исходный файл разделит на несколько файлов поменьше и перенесет в них только строки по определенному критерию. То есть в колонке J записаны названия города (в примере Винница, Днепр, Киев) нужно создать файлы Винница_сегодняшняя_дата, Днепр_сегодняшняя_дата и т.д. и чтобы в новом файле остались только строки в которых название файла соответствует значению колонки J.
Я в VBA можно сказать новичок, это мой второй макрос, прошу сильно не ругать если плохо написал. Вот что у мене получилось:
st = Timer Dim X As String strDate = Format(Now, "dd.mm") On Error Resume Next MkDir "C:\отчёт\август\" & strDate 'создать новую папку strPath = "C:\отчёт\август\" & strDate 'папка для сохранения книги On Error Resume Next X = GetAttr(strPath) And 0 If Err = 0 Then ' если путь существует - сохраняем книгу, добавляя дату Dim i As Integer LastCell1 = Sheets("Info").Range("A1").End(xlDown).Row 'For i = 2 To 3 For i = 2 To LastCell1 FileNameXls = strPath & "\" & Sheets("Info").Cells(i, 1).Value & " " & strDate & ".xlsx" 'создание копий файлов с именами из ячеек листа "Info" ActiveWorkbook.SaveCopyAs Filename:=FileNameXls Workbooks.Open Filename:=FileNameXls 'открыть созданый файл
Dim n As Integer Dim Podr As String Dim PodrNow As String PodrNow = Sheets("Info").Cells(i, 1).Value LastCell2 = Sheets("Исх").Range("J1").End(xlDown).Row For n = LastCell2 To 2 Step -1 Podr = Sheets("Исх").Cells(n, 10).Value If Podr <> PodrNow Then Sheets("Исх").Rows(n).Delete Next
Dim wsSh As Worksheet, PVTable As PivotTable 'обновление всех сводных For Each wsSh In Worksheets For Each PVTable In wsSh.PivotTables: PVTable.RefreshTable: Next PVTable Next wsSh
Workbooks(Sheets("Info").Cells(i, 1).Value & " " & strDate & ".xlsx").Close SaveChanges:=True 'SAVE AND CLOSE Next i Else 'если путь не существует - выводим сообщение MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical End If fsh = Timer MsgBox "Все ОК! Время работы макроса: " & (fsh - st) \ 60 & " мин. " & Round((fsh - st) - (((fsh - st) \ 60) * 60), 0) & " сек."
Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True End Sub
[/vba]
В двух словах о макросе. Даные о количистве файлов и их название макрос берет из листа "Info" количество названий будет всегда одинаково и меняться не будет. Для роботы макроса нужно на диске С иметь путь C:\отчёт\август\ (наверно можно сделать чтобы макрос создавал файлы в папке текущего рабочего файла, пока написал так, пока не критично).
С моими знаниями VBA я смог написать макрос который будет перебирать значение ячеек колонки J и удалять те которые не соответствуют критерию. Но этот метод очень долгий. Как оптимизировать не знаю.
[vba]
Код
Dim n As Integer Dim Podr As String Dim PodrNow As String PodrNow = Sheets("Info").Cells(i, 1).Value LastCell2 = Sheets("Исх").Range("J1").End(xlDown).Row For n = LastCell2 To 2 Step -1 Podr = Sheets("Исх").Cells(n, 10).Value If Podr <> PodrNow Then Sheets("Исх").Rows(n).Delete Next
[/vba]
Тестировал на файле из 13 тис строк. для создания одного файла требуется около 2 минут. Таких файлов нужно будет делать 25, исходник будет состоять из 80 тис строк. Думаю будет очеееень долго, а своими силами не знаю как изменить макрос чтоб работал шустрее.
Sub SaveCopy() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.DisplayAlerts = False Dim st#, strDate$, strPath$, LastCell1&, FileNameXls$, fsh#, a, i&, n&, m&, j&, r As Range, k& st = Timer Dim X As String strDate = Format(Now, "dd.mm") ' On Error Resume Next strPath = ThisWorkbook.Path & "\отчёт\август\" & strDate 'создать новую папку CreateObject("Shell.Application").Namespace(Left(ThisWorkbook.Path, 3)).NewFolder (Mid(ThisWorkbook.Path, 4) & "\отчёт\август\" & strDate) LastCell1 = Sheets("Info").Range("A1").End(xlDown).Row For i = 2 To LastCell1 FileNameXls = strPath & "\" & Sheets("Info").Cells(i, 1).Value & " " & strDate & ".xlsx" 'создание копий файлов с именами из ячеек листа "Info" ActiveWorkbook.SaveCopyAs Filename:=FileNameXls With Workbooks.Open(FileNameXls) 'открыть созданый файл Dim Podr As String Dim PodrNow As String PodrNow = Sheets("Info").Cells(i, 1).Value Set r = .Sheets("Исх").[a1].CurrentRegion a = r.Value: n = 1 For m = 2 To UBound(a) If a(m, 10) = PodrNow Then n = n + 1: For k = 1 To 10: a(n, k) = a(m, k): Next Next r.ClearContents .Sheets("Исх").[a1].Resize(n, 10) = a Dim wsSh As Worksheet, PVTable As PivotTable 'обновление всех сводных For Each wsSh In .Worksheets For Each PVTable In wsSh.PivotTables: PVTable.RefreshTable: Next PVTable Next wsSh .Close -1 End With Next i fsh = Timer MsgBox "Все ОК! Время работы макроса: " & (fsh - st) \ 60 & " мин. " & Round((fsh - st) - (((fsh - st) \ 60) * 60), 0) & " сек." Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True End Sub
[/vba]
Все будет зависеть от скорости винта:
[vba]
Код
Sub SaveCopy() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.DisplayAlerts = False Dim st#, strDate$, strPath$, LastCell1&, FileNameXls$, fsh#, a, i&, n&, m&, j&, r As Range, k& st = Timer Dim X As String strDate = Format(Now, "dd.mm") ' On Error Resume Next strPath = ThisWorkbook.Path & "\отчёт\август\" & strDate 'создать новую папку CreateObject("Shell.Application").Namespace(Left(ThisWorkbook.Path, 3)).NewFolder (Mid(ThisWorkbook.Path, 4) & "\отчёт\август\" & strDate) LastCell1 = Sheets("Info").Range("A1").End(xlDown).Row For i = 2 To LastCell1 FileNameXls = strPath & "\" & Sheets("Info").Cells(i, 1).Value & " " & strDate & ".xlsx" 'создание копий файлов с именами из ячеек листа "Info" ActiveWorkbook.SaveCopyAs Filename:=FileNameXls With Workbooks.Open(FileNameXls) 'открыть созданый файл Dim Podr As String Dim PodrNow As String PodrNow = Sheets("Info").Cells(i, 1).Value Set r = .Sheets("Исх").[a1].CurrentRegion a = r.Value: n = 1 For m = 2 To UBound(a) If a(m, 10) = PodrNow Then n = n + 1: For k = 1 To 10: a(n, k) = a(m, k): Next Next r.ClearContents .Sheets("Исх").[a1].Resize(n, 10) = a Dim wsSh As Worksheet, PVTable As PivotTable 'обновление всех сводных For Each wsSh In .Worksheets For Each PVTable In wsSh.PivotTables: PVTable.RefreshTable: Next PVTable Next wsSh .Close -1 End With Next i fsh = Timer MsgBox "Все ОК! Время работы макроса: " & (fsh - st) \ 60 & " мин. " & Round((fsh - st) - (((fsh - st) \ 60) * 60), 0) & " сек." Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True End Sub
чтобы макрос создавал файлы в папке текущего рабочего файла
[vba]
Код
Sub RaznestiDannye() Dim i As Long Dim Criterij As String Dim iName As String Dim WbN As Workbook Dim Autofilter As Autofilter Application.ScreenUpdating = False For i = 2 To 4 'цикл по городам Criterij = Worksheets("Info").Cells(i, 1) iName = Criterij 'имя новой книги 'создаем новую книгу с одним листом Set WbN = Workbooks.Add(xlWBATWorksheet) ThisWorkbook.Worksheets("Исх").Activate 'ставим автофильтр по столбцу J Range("A1").CurrentRegion.Autofilter 10, Criterij 'копируем видимые строки в новую книгу ActiveSheet.Autofilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1") ActiveSheet.Autofilter.Range.Autofilter
WbN.Sheets("Лист1").Columns("A:J").AutoFit WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls" WbN.Close SaveChanges:=True Next Application.ScreenUpdating = True End Sub
[/vba]
Дату в название файлов допишите сами. Удачи!
Цитата
чтобы макрос создавал файлы в папке текущего рабочего файла
[vba]
Код
Sub RaznestiDannye() Dim i As Long Dim Criterij As String Dim iName As String Dim WbN As Workbook Dim Autofilter As Autofilter Application.ScreenUpdating = False For i = 2 To 4 'цикл по городам Criterij = Worksheets("Info").Cells(i, 1) iName = Criterij 'имя новой книги 'создаем новую книгу с одним листом Set WbN = Workbooks.Add(xlWBATWorksheet) ThisWorkbook.Worksheets("Исх").Activate 'ставим автофильтр по столбцу J Range("A1").CurrentRegion.Autofilter 10, Criterij 'копируем видимые строки в новую книгу ActiveSheet.Autofilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1") ActiveSheet.Autofilter.Range.Autofilter
WbN.Sheets("Лист1").Columns("A:J").AutoFit WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls" WbN.Close SaveChanges:=True Next Application.ScreenUpdating = True End Sub
[/vba]
Дату в название файлов допишите сами. Удачи!Kuzmich
Сообщение отредактировал Kuzmich - Воскресенье, 27.08.2017, 20:38
а у автофильтра помнится, ограничение в ~8100 видимых областей. Поэтому сразу пошел другим путем. А еще ТС сохраняет листы со сводными в созданных книгах.
а у автофильтра помнится, ограничение в ~8100 видимых областей. Поэтому сразу пошел другим путем. А еще ТС сохраняет листы со сводными в созданных книгах.KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Сообщение отредактировал KuklP - Воскресенье, 27.08.2017, 20:44
Извиняюсь. Пост отредактировал, файл с поддержкой макросов добавил(надеюсь сделал это правильно). Спасибо что откликнулись. Буду изучать Ваши коды, спасибо!
П.С. Строк будет много, но в колонке J уникальных значений будет всего около 25. Может фильтр поможет, или я не в ту степь думаю? Завтра попробую на тестовом файле в нем 13928 строк и 11 уникальных значений подразделений(J).
Извиняюсь. Пост отредактировал, файл с поддержкой макросов добавил(надеюсь сделал это правильно). Спасибо что откликнулись. Буду изучать Ваши коды, спасибо!
П.С. Строк будет много, но в колонке J уникальных значений будет всего около 25. Может фильтр поможет, или я не в ту степь думаю? Завтра попробую на тестовом файле в нем 13928 строк и 11 уникальных значений подразделений(J).Iurii
Можно поступить немного по-другому: делаем два макроса: - Один будет просто читать список-исходник, и в текущей книге копировать строчки на листы с именами, соответствующими ключам (города из столбца J). Получим в текущей книге набор листов в количестве, соответствующем всем имеющимся городам, один проход по списку, никаких автофильтров и возможных ограничений - Второй макрос будет просто уметь сохранять данные листа в файл, принципы задавания имени для этого файла - на ваше усмотрение, хоть передавайте параметром.
Единая "зеленая кнопка" - тоже простенький (третий) макрос: вызываем первый макрос, затем в цикле по нужным листам - вызываем второй.
Можно поступить немного по-другому: делаем два макроса: - Один будет просто читать список-исходник, и в текущей книге копировать строчки на листы с именами, соответствующими ключам (города из столбца J). Получим в текущей книге набор листов в количестве, соответствующем всем имеющимся городам, один проход по списку, никаких автофильтров и возможных ограничений - Второй макрос будет просто уметь сохранять данные листа в файл, принципы задавания имени для этого файла - на ваше усмотрение, хоть передавайте параметром.
Единая "зеленая кнопка" - тоже простенький (третий) макрос: вызываем первый макрос, затем в цикле по нужным листам - вызываем второй.AndreTM
Сомнительная простота, Андрей В №3 все делается одним макросом, не надо плодить листы в книге и сводные в книгах сохраняются, и файлы падают по пути в каталог источника.
Сомнительная простота, Андрей В №3 все делается одним макросом, не надо плодить листы в книге и сводные в книгах сохраняются, и файлы падают по пути в каталог источника.KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Огромное спасибо за помощь! Макрос работает очень быстро (тестировал на файле из 14 тис. строк, создание 11 файлов занимает около 30 сек.) Осталось заставить макрос обновить источник даных в сводных так как в сводной лезут пустые значения. Думаю это не очень сложно
Огромное спасибо за помощь! Макрос работает очень быстро (тестировал на файле из 14 тис. строк, создание 11 файлов занимает около 30 сек.) Осталось заставить макрос обновить источник даных в сводных так как в сводной лезут пустые значения. Думаю это не очень сложно Iurii
Сергей, давай посмотрим Кстати, моё предложение касалось в основном именно затрат времени на выборку нужных частей информации. Время создания файлов, или обновления сводных - это отдельная тема.
Напомню, предложенная методика примерно такова: - Создаем N (25) пустых листов (можно по данным из Info, можно прямо в процессе работы, в следующем пункте) - Для отбора проходим Исходный список один раз (R строк, R итераций) (естественно, можно в массиве - одно чтение R строк), копируя строки на соответствующие листы. Причем и запись идет R1 + R2 + ... + Rn = R суммарно строк, просто по строке за раз. Но никто не запрещает нам организовать словарь массивов, чтобы выполнить запись на листы "за один раз на каждый" после окончания прохода Исходника, при этом тут же и создавая сами пустые листы. Запись будет идти N раз, в сумме запишется R строк. - N раз сохраняем листы в файлы. Листы мы при этом можем перемещать в новые файлы, чтобы не заморачиваться с их удалением их исходного файла Да, конечно, ещё остается вопрос со сводными таблицами. Но мы можем же, копируя листы в новые файлы - сразу же либо полностью программно сгененерировать своды, либо скопировать имеющиеся, заменяя SourceData в копиях (что приведет сразу и к рефрешу).
А теперь #3:
- Вроде бы краткость кода создания копий файлов, особенно в части того, что своды скопируются тоже сразу. Но вот если в исходном файле будут ещё "лишние" листы, которые в копиях не нужны... Файлы создаются N раз. - В копии переносится сначала вся информация, а затем необходима ещё чистка диапазона и перезапись его только необходимым строками (что и выполняется в моём методе, только без чистки). - Чтение информации (N чтений по R строк), отбор же суммарно занимает R*N итераций, плюс суммарно R итераций (R1 + R2 + ...) по перезаписи данных внутри массива. Запись идет N раз, записывается суммарно R строк. - Обновление сводных сравнимо по времени с их новой генерацией/копированием с заменой SourceData. При этом сводные сохраняют излишний SourceData-диапазон, что замедляет расчет из-за наличия пустых строк данных. То есть мы видим, что по времени обработки этот метод проиграет предложенному, причем именно на этапе разбивки информации на части. Тем более, что и в моём варианте мы можем не копировать отдельные листы, а так же наделать копий всего файла, просто сразу вычищая там лист "Исх", и записывая по местам отбираемое в Исходнике.
Заодно:
Вариант же из #4 по подходу к самому созданию файлов - практически ничем не отличается от предложенного мной (создается N листов, просто сразу в другой книге). А вот про ограниченность автофильтра уже сказано, плюс ещё вопрос, что быстрее - наложить N раз фильтр на все R записей, или один раз пройти эти R записей. Даже если ускорить копирование за счет записи через память. Практика показывает, что на большом количестве записей автофильтр притормаживает очень неслабо Да ещё там и своды не учтены...
Сергей, давай посмотрим Кстати, моё предложение касалось в основном именно затрат времени на выборку нужных частей информации. Время создания файлов, или обновления сводных - это отдельная тема.
Напомню, предложенная методика примерно такова: - Создаем N (25) пустых листов (можно по данным из Info, можно прямо в процессе работы, в следующем пункте) - Для отбора проходим Исходный список один раз (R строк, R итераций) (естественно, можно в массиве - одно чтение R строк), копируя строки на соответствующие листы. Причем и запись идет R1 + R2 + ... + Rn = R суммарно строк, просто по строке за раз. Но никто не запрещает нам организовать словарь массивов, чтобы выполнить запись на листы "за один раз на каждый" после окончания прохода Исходника, при этом тут же и создавая сами пустые листы. Запись будет идти N раз, в сумме запишется R строк. - N раз сохраняем листы в файлы. Листы мы при этом можем перемещать в новые файлы, чтобы не заморачиваться с их удалением их исходного файла Да, конечно, ещё остается вопрос со сводными таблицами. Но мы можем же, копируя листы в новые файлы - сразу же либо полностью программно сгененерировать своды, либо скопировать имеющиеся, заменяя SourceData в копиях (что приведет сразу и к рефрешу).
А теперь #3:
- Вроде бы краткость кода создания копий файлов, особенно в части того, что своды скопируются тоже сразу. Но вот если в исходном файле будут ещё "лишние" листы, которые в копиях не нужны... Файлы создаются N раз. - В копии переносится сначала вся информация, а затем необходима ещё чистка диапазона и перезапись его только необходимым строками (что и выполняется в моём методе, только без чистки). - Чтение информации (N чтений по R строк), отбор же суммарно занимает R*N итераций, плюс суммарно R итераций (R1 + R2 + ...) по перезаписи данных внутри массива. Запись идет N раз, записывается суммарно R строк. - Обновление сводных сравнимо по времени с их новой генерацией/копированием с заменой SourceData. При этом сводные сохраняют излишний SourceData-диапазон, что замедляет расчет из-за наличия пустых строк данных. То есть мы видим, что по времени обработки этот метод проиграет предложенному, причем именно на этапе разбивки информации на части. Тем более, что и в моём варианте мы можем не копировать отдельные листы, а так же наделать копий всего файла, просто сразу вычищая там лист "Исх", и записывая по местам отбираемое в Исходнике.
Заодно:
Вариант же из #4 по подходу к самому созданию файлов - практически ничем не отличается от предложенного мной (создается N листов, просто сразу в другой книге). А вот про ограниченность автофильтра уже сказано, плюс ещё вопрос, что быстрее - наложить N раз фильтр на все R записей, или один раз пройти эти R записей. Даже если ускорить копирование за счет записи через память. Практика показывает, что на большом количестве записей автофильтр притормаживает очень неслабо Да ещё там и своды не учтены...
Помогите еще разобраться с обновлением границ сводной. Почти нашел решение,но не доконца
[vba]
Код
Sheets("Исх").Select Cells(1, 1).Select Selection.AutoFilter Selection.CurrentRegion.Select numRows = Selection.Rows.Count numColumns = Selection.Columns.Count ' к-во строк и колонок в таблице в новом листе ИСХ, чтоб узнать где кончаеться таблица For List = 1 To 4 ' к-во листов в новом файле(пока написал числом) For pt = 1 To ActiveWorkbook.Sheets(List).PivotTables.Count ActiveWorkbook.Sheets(List).PivotTables(pt).PivotTableWizard SourceType:=xlDatabase, SourceData:= _ Sheets("Исх").Cells(numRows, numColumns).Address ' здесь накрутил. не знаю как выбрать диапазон с листа ИСХ с ячейки а1 по (numRows, numColumns) Next pt Next List
[/vba]
Спасибо!
Помогите еще разобраться с обновлением границ сводной. Почти нашел решение,но не доконца
[vba]
Код
Sheets("Исх").Select Cells(1, 1).Select Selection.AutoFilter Selection.CurrentRegion.Select numRows = Selection.Rows.Count numColumns = Selection.Columns.Count ' к-во строк и колонок в таблице в новом листе ИСХ, чтоб узнать где кончаеться таблица For List = 1 To 4 ' к-во листов в новом файле(пока написал числом) For pt = 1 To ActiveWorkbook.Sheets(List).PivotTables.Count ActiveWorkbook.Sheets(List).PivotTables(pt).PivotTableWizard SourceType:=xlDatabase, SourceData:= _ Sheets("Исх").Cells(numRows, numColumns).Address ' здесь накрутил. не знаю как выбрать диапазон с листа ИСХ с ячейки а1 по (numRows, numColumns) Next pt Next List
и если судить по алгоритму в описании, то и по скорости преимущество очень сомнительно, и макросы существенно сложней. ИМХО. Впрочем основную часть времени занимает запись-чтение файлов с(на) диск. Так что небольшой разницей в скорости можно пренебречь. В №3 отбор уместился в 3 строки: [vba]
Код
For m = 2 To UBound(a) If a(m, 10) = PodrNow Then n = n + 1: For k = 1 To 10: a(n, k) = a(m, k): Next Next
[/vba] Проще(а может только читабельней) только построчное копирование ячеек, что очень замедлит выполнение.
и если судить по алгоритму в описании, то и по скорости преимущество очень сомнительно, и макросы существенно сложней. ИМХО. Впрочем основную часть времени занимает запись-чтение файлов с(на) диск. Так что небольшой разницей в скорости можно пренебречь. В №3 отбор уместился в 3 строки: [vba]
Код
For m = 2 To UBound(a) If a(m, 10) = PodrNow Then n = n + 1: For k = 1 To 10: a(n, k) = a(m, k): Next Next
[/vba] Проще(а может только читабельней) только построчное копирование ячеек, что очень замедлит выполнение. KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Сообщение отредактировал KuklP - Понедельник, 28.08.2017, 16:06
Dim wsSh As Worksheet, PVTable As PivotTable For Each wsSh In .Worksheets For Each PVTable In wsSh.PivotTables PVTable.ChangePivotCache wsSh.Parent. _ PivotCaches.Create(SourceType:=xlDatabase, SourceData:=wsSh.Parent.Sheets("Исх").[a1].CurrentRegion, _ Version:=xlPivotTableVersion15) Next PVTable Next wsSh
[/vba]
Iurii, наверное, что-то вроде такого: [vba]
Код
Dim wsSh As Worksheet, PVTable As PivotTable For Each wsSh In .Worksheets For Each PVTable In wsSh.PivotTables PVTable.ChangePivotCache wsSh.Parent. _ PivotCaches.Create(SourceType:=xlDatabase, SourceData:=wsSh.Parent.Sheets("Исх").[a1].CurrentRegion, _ Version:=xlPivotTableVersion15) Next PVTable Next wsSh
Лукавить не надо, а? Восемь там строк, а не три. А если строго - то там три блока, причем к "строкам" они отношения не имеют. Да и забываешь указать что у тебя "эти три строчки" выполняются внутри другого цикла. Кроме того, как количество строк кода может влиять на быстродействие? Влияет количество операций, да ещё и помноженное на количество итераций.
Лукавить не надо, а? Восемь там строк, а не три. А если строго - то там три блока, причем к "строкам" они отношения не имеют. Да и забываешь указать что у тебя "эти три строчки" выполняются внутри другого цикла. Кроме того, как количество строк кода может влиять на быстродействие? Влияет количество операций, да ещё и помноженное на количество итераций.AndreTM
Skype: andre.tm.007 Donate: Qiwi: 9517375010
Сообщение отредактировал AndreTM - Понедельник, 28.08.2017, 16:42
у ТС запись 11 файлов занимает 30 (ну, пусть 20) секунд
он так и пишет. Все остальное происходит в памяти практически мгновенно. И раздели ты макрос хоть на 20 "маленьких медвежат"(с), существенного прироста в скорости не получится. Практически все время затрачивается на чтение-запись диска.
у ТС запись 11 файлов занимает 30 (ну, пусть 20) секунд
он так и пишет. Все остальное происходит в памяти практически мгновенно. И раздели ты макрос хоть на 20 "маленьких медвежат"(с), существенного прироста в скорости не получится. Практически все время затрачивается на чтение-запись диска.KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
AndreTM, Спасибо работает. Границы сводной обновляет. Но если воспользоваться фильтром в новой сводной выдает ошибку: "отчет сводной таблицы был сохранен без данных. Для обновления отчета используйте команду "обновить даные""
Ранее пользовался макросом только для обновления даных в сводной(но вылазили пустые ячейки в сводной) фильтр работал [vba]
Код
For Each wsSh In .Worksheets For Each PVTable In wsSh.PivotTables: PVTable.RefreshTable: Next PVTable Next wsSh
[/vba]
Пытаюсь добавить эти строки в Ваш код - все работает но фильт не работает . Пробовал запускать эти коды по очереди - тобе безрезультатно. Не подскажите в чем проблема? Спасибо!
AndreTM, Спасибо работает. Границы сводной обновляет. Но если воспользоваться фильтром в новой сводной выдает ошибку: "отчет сводной таблицы был сохранен без данных. Для обновления отчета используйте команду "обновить даные""
Ранее пользовался макросом только для обновления даных в сводной(но вылазили пустые ячейки в сводной) фильтр работал [vba]
Код
For Each wsSh In .Worksheets For Each PVTable In wsSh.PivotTables: PVTable.RefreshTable: Next PVTable Next wsSh
[/vba]
Пытаюсь добавить эти строки в Ваш код - все работает но фильт не работает . Пробовал запускать эти коды по очереди - тобе безрезультатно. Не подскажите в чем проблема? Спасибо!Iurii
Сообщение отредактировал Iurii - Понедельник, 28.08.2017, 18:15
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
В №3 все делается одним макросом, не надо плодить листы в книге и сводные в книгах сохраняются, и файлы падают по пути в каталог источника.
