'Шаг 3: Открываем файлы один за другим Workbooks.Open MyFolder & MyFiles
'Код макроса с действиями Workbooks(MyFiles).RefreshAll Workbooks(MyFiles).Close SaveChanges:=True
'Шаг 4: Следующий файл в папке MyFiles = Dir Loop Call Ended(AutoCalculat) End Sub
Private Function FolderDialogOpen$() ' Description: Функция запрашивает папку и возвращает путь к ней On Error Resume Next With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Выберите папку в которой нужно обновить файлы." .InitialFileName = ThisWorkbook.Path .AllowMultiSelect = False .ButtonName = "Выбрать" .Show If .SelectedItems.Count = 1 Then FolderDialogOpen = .SelectedItems(1) Else MsgBox "Вы ничего не выбрали!" & VBA.vbCrLf & "Работа макроса завершена.": End End With End Function
Private Function Prepare() As Boolean ' Description: отключаем пересчет, обновление экрана и т.п. On Error Resume Next ActiveCell.Worksheet.DisplayPageBreaks = False 'Отображение границ страниц, тоже почему-то помогает. With Application .ScreenUpdating = False 'Обновление экрана, чтобы ничего не мигало. .EnableEvents = False 'Не обрабатывать события. .DisplayStatusBar = False 'В статусной строке выводятся различные данные, что замедляет работу, отключаем. .DisplayAlerts = False 'Выключает сообщения Экселя. Prepare = .Calculation = xlAutomatic: .Calculation = xlManual 'Включает ручной пересчет. End With On Error GoTo 0 End Function
Private Function Ended(AutoCalculat As Boolean) ' Description: включаем пересчет, обновление экрана и т.п. On Error Resume Next ActiveCell.Worksheet.DisplayPageBreaks = True With Application .ScreenUpdating = True .EnableEvents = True .DisplayStatusBar = True .DisplayAlerts = True .Calculation = VBA.IIf(AutoCalculat, xlAutomatic, xlManual) End With On Error GoTo 0 End Function
[/vba]
rabotarzhenetskiy, здравствуйте,
[vba]
Код
Sub OtkritVseKnigi() 'Шаг 1:Объявляем переменные Dim MyFiles As String Dim MyFolder As String Dim AutoCalculat As Boolean
'Шаг 3: Открываем файлы один за другим Workbooks.Open MyFolder & MyFiles
'Код макроса с действиями Workbooks(MyFiles).RefreshAll Workbooks(MyFiles).Close SaveChanges:=True
'Шаг 4: Следующий файл в папке MyFiles = Dir Loop Call Ended(AutoCalculat) End Sub
Private Function FolderDialogOpen$() ' Description: Функция запрашивает папку и возвращает путь к ней On Error Resume Next With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Выберите папку в которой нужно обновить файлы." .InitialFileName = ThisWorkbook.Path .AllowMultiSelect = False .ButtonName = "Выбрать" .Show If .SelectedItems.Count = 1 Then FolderDialogOpen = .SelectedItems(1) Else MsgBox "Вы ничего не выбрали!" & VBA.vbCrLf & "Работа макроса завершена.": End End With End Function
Private Function Prepare() As Boolean ' Description: отключаем пересчет, обновление экрана и т.п. On Error Resume Next ActiveCell.Worksheet.DisplayPageBreaks = False 'Отображение границ страниц, тоже почему-то помогает. With Application .ScreenUpdating = False 'Обновление экрана, чтобы ничего не мигало. .EnableEvents = False 'Не обрабатывать события. .DisplayStatusBar = False 'В статусной строке выводятся различные данные, что замедляет работу, отключаем. .DisplayAlerts = False 'Выключает сообщения Экселя. Prepare = .Calculation = xlAutomatic: .Calculation = xlManual 'Включает ручной пересчет. End With On Error GoTo 0 End Function
Private Function Ended(AutoCalculat As Boolean) ' Description: включаем пересчет, обновление экрана и т.п. On Error Resume Next ActiveCell.Worksheet.DisplayPageBreaks = True With Application .ScreenUpdating = True .EnableEvents = True .DisplayStatusBar = True .DisplayAlerts = True .Calculation = VBA.IIf(AutoCalculat, xlAutomatic, xlManual) End With On Error GoTo 0 End Function