Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Команда "Обновить всё" во всех файлах с выбором папки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Команда "Обновить всё" во всех файлах с выбором папки
rabotarzhenetskiy Дата: Воскресенье, 17.04.2022, 10:54 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Добрый день.
Есть макрос, который выполняет команду "Обновить всё" во всех файлах указанной папки.
[vba]
Код
Sub OtkritVseKnigi()
'Шаг 1:Объявляем переменные
Dim MyFiles As String

'Шаг 2: Укажите нужную папку
MyFiles = Dir("C:\temp\*.xlsb")
Do While MyFiles <> ""

'Шаг 3: Открываем файлы один за другим
Workbooks.Open "C:\temp\" & MyFiles

'Код макроса с действиями
ActiveWorkbook.RefreshAll
ActiveWorkbook.Close SaveChanges:=True

'Шаг 4: Следующий файл в папке
MyFiles = Dir
Loop
End Sub
[/vba]
Подскажите, пожалуйста, как этот макрос изменить, чтобы папка выбиралась при запуске макроса и файлы обновлялись в фоне.

Заранее спасибо.
 
Ответить
СообщениеДобрый день.
Есть макрос, который выполняет команду "Обновить всё" во всех файлах указанной папки.
[vba]
Код
Sub OtkritVseKnigi()
'Шаг 1:Объявляем переменные
Dim MyFiles As String

'Шаг 2: Укажите нужную папку
MyFiles = Dir("C:\temp\*.xlsb")
Do While MyFiles <> ""

'Шаг 3: Открываем файлы один за другим
Workbooks.Open "C:\temp\" & MyFiles

'Код макроса с действиями
ActiveWorkbook.RefreshAll
ActiveWorkbook.Close SaveChanges:=True

'Шаг 4: Следующий файл в папке
MyFiles = Dir
Loop
End Sub
[/vba]
Подскажите, пожалуйста, как этот макрос изменить, чтобы папка выбиралась при запуске макроса и файлы обновлялись в фоне.

Заранее спасибо.

Автор - rabotarzhenetskiy
Дата добавления - 17.04.2022 в 10:54
boa Дата: Воскресенье, 17.04.2022, 18:45 | Сообщение № 2
Группа: Друзья
Ранг: Ветеран
Сообщений: 559
Репутация: 167 ±
Замечаний: 0% ±

365
rabotarzhenetskiy, здравствуйте,

[vba]
Код
Sub OtkritVseKnigi()
'Шаг 1:Объявляем переменные
Dim MyFiles As String
Dim MyFolder As String
Dim AutoCalculat As Boolean

'Шаг 2: Укажите нужную папку
MyFolder = FolderDialogOpen & "\"
MyFiles = Dir(MyFolder & "*.xlsb")
AutoCalculat = Prepare
  Do While MyFiles <> ""
  
    'Шаг 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

'Шаг 2: Укажите нужную папку
MyFolder = FolderDialogOpen & "\"
MyFiles = Dir(MyFolder & "*.xlsb")
AutoCalculat = Prepare
  Do While MyFiles <> ""
  
    'Шаг 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]

Автор - boa
Дата добавления - 17.04.2022 в 18:45
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!