Всем привет. Такой вопрос возник у меня в ходе разработки. Есть макрос - сохраняет текущий файл в две разные папки на сетевых дисках + создает еще одни файл куда будут агрегироваться некие итоги. Если этот файл запускать в каждом отдельном файле - все работает корректно - файлы сохраняются в нужные папки, доп файл в одной из них создается. Но вставив этот код в цикл по всем файлам обнаружил, что в нем макрос корреткно сохраняет файлы только в первую папку, в во вторую сохраняет только первый файл+ агрегатный файл - т.е. цикл по остальным файлам к этой папке почему-то не применяется. В чем может быть причина? Код:
[vba]
Код
Sub Сохранить_в_файлы() On Error Resume Next Application.ScreenUpdating = False ' Сохранение нужных листов для отчетов Dim NewWb As Workbook 'Заносим имя текущей книги в переменную n = ActiveWorkbook.Name 'Создаем новую книгу с 1-м пустым листом Set NewWb = Workbooks.Add(1) 'Активируем старую книгу Windows(n).Activate 'Указываем массивом листы, которые хотим скопировать Sheets(Array("по дням", "накопительно", "ТОП", "ABC", "PL")).Copy Before:=Workbooks(NewWb.Name).Sheets(1) ' Отключаем любые окна предупреждений Application.DisplayAlerts = False ' Удаляем существовавший пустой лист Sheets("Лист1").Delete Sheets("накопительно").Activate Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select ' Сохраняем книгу по данным первых ячеек, с нужным именем s = Mid(n, InStrRev(n, "\") + 1, InStrRev(n, ".") - InStrRev(n, "\") - 1) Call Создание_папки ' создаем нужные папки Call Связи 'разрываем все связи ActiveWorkbook.SaveAs FileName:=aa & s & " по " & DateValue(Now) - 1 & " включительно.xlsx" ActiveWorkbook.SaveAs FileName:=dd & s & " по " & DateValue(Now) - 1 & " включительно.xlsx" 'Закрываем книгу ActiveWorkbook.Close 'Сбрасываем выделение 'Windows(n).Worksheets(2).Range("A2").Select Workbooks(n).Save 'Создаем агрегатный файл Set NewWb = Workbooks.Add(1) ActiveWorkbook.SaveAs FileName:=dd & "Для рассылки на " & DateValue(Now) & ".xlsx" ActiveWorkbook.Close Windows(n).Close Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
[/vba]
В dd отказывается сохранять корректно, подозреваю что из-за создания доп. файла
Код цикла:
[vba]
Код
Sub Обработка_цикл() Dim whr As Worksheet 'On Error Resume Next 'Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlManual Application.CalculateBeforeSave = False n = ActiveWorkbook.Name MyPath = MyPath & ActiveWorkbook.Path & IIf(Right(MyPath, 1) = Application.PathSeparator, "", Application.PathSeparator) MyFileName = Dir(MyPath & "Отчет*.xls*") Do Until MyFileName = "" MyFullName = MyPath & MyFileName Workbooks.Open FileName:=MyFullName, UpdateLinks:=0 s = ActiveWorkbook.Name Call Общий_обработчик Call Сохранить_в_файлы MyFileName = Dir Loop End Sub
[/vba]
Всем привет. Такой вопрос возник у меня в ходе разработки. Есть макрос - сохраняет текущий файл в две разные папки на сетевых дисках + создает еще одни файл куда будут агрегироваться некие итоги. Если этот файл запускать в каждом отдельном файле - все работает корректно - файлы сохраняются в нужные папки, доп файл в одной из них создается. Но вставив этот код в цикл по всем файлам обнаружил, что в нем макрос корреткно сохраняет файлы только в первую папку, в во вторую сохраняет только первый файл+ агрегатный файл - т.е. цикл по остальным файлам к этой папке почему-то не применяется. В чем может быть причина? Код:
[vba]
Код
Sub Сохранить_в_файлы() On Error Resume Next Application.ScreenUpdating = False ' Сохранение нужных листов для отчетов Dim NewWb As Workbook 'Заносим имя текущей книги в переменную n = ActiveWorkbook.Name 'Создаем новую книгу с 1-м пустым листом Set NewWb = Workbooks.Add(1) 'Активируем старую книгу Windows(n).Activate 'Указываем массивом листы, которые хотим скопировать Sheets(Array("по дням", "накопительно", "ТОП", "ABC", "PL")).Copy Before:=Workbooks(NewWb.Name).Sheets(1) ' Отключаем любые окна предупреждений Application.DisplayAlerts = False ' Удаляем существовавший пустой лист Sheets("Лист1").Delete Sheets("накопительно").Activate Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select ' Сохраняем книгу по данным первых ячеек, с нужным именем s = Mid(n, InStrRev(n, "\") + 1, InStrRev(n, ".") - InStrRev(n, "\") - 1) Call Создание_папки ' создаем нужные папки Call Связи 'разрываем все связи ActiveWorkbook.SaveAs FileName:=aa & s & " по " & DateValue(Now) - 1 & " включительно.xlsx" ActiveWorkbook.SaveAs FileName:=dd & s & " по " & DateValue(Now) - 1 & " включительно.xlsx" 'Закрываем книгу ActiveWorkbook.Close 'Сбрасываем выделение 'Windows(n).Worksheets(2).Range("A2").Select Workbooks(n).Save 'Создаем агрегатный файл Set NewWb = Workbooks.Add(1) ActiveWorkbook.SaveAs FileName:=dd & "Для рассылки на " & DateValue(Now) & ".xlsx" ActiveWorkbook.Close Windows(n).Close Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
[/vba]
В dd отказывается сохранять корректно, подозреваю что из-за создания доп. файла
Код цикла:
[vba]
Код
Sub Обработка_цикл() Dim whr As Worksheet 'On Error Resume Next 'Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlManual Application.CalculateBeforeSave = False n = ActiveWorkbook.Name MyPath = MyPath & ActiveWorkbook.Path & IIf(Right(MyPath, 1) = Application.PathSeparator, "", Application.PathSeparator) MyFileName = Dir(MyPath & "Отчет*.xls*") Do Until MyFileName = "" MyFullName = MyPath & MyFileName Workbooks.Open FileName:=MyFullName, UpdateLinks:=0 s = ActiveWorkbook.Name Call Общий_обработчик Call Сохранить_в_файлы MyFileName = Dir Loop End Sub
Уряяяя))) Сам нашел решение - стоило убрать On Error Resume Next и ошибка нашлась сама и совсем не там, где ожидал. Т.к. создание папок тоже получилось завернутым в цикл именно там появлялась ошибка конкатенации, когда к уже собранному пути сохранения добавлялось оно же. Получалась полная белидерда. Вынес вызов создания папок в Обработку циклом до прохода всех файлов и все заработало как нужно
Уряяяя))) Сам нашел решение - стоило убрать On Error Resume Next и ошибка нашлась сама и совсем не там, где ожидал. Т.к. создание папок тоже получилось завернутым в цикл именно там появлялась ошибка конкатенации, когда к уже собранному пути сохранения добавлялось оно же. Получалась полная белидерда. Вынес вызов создания папок в Обработку циклом до прохода всех файлов и все заработало как нужно IgorStorm