Уважаемые эксперты, посоветуйте пож-та доработку кода на предмет переборки в папке не выбранных в массив файлов и совершения с каждым одиночной операции с последующим сохранением. Цель всего мероприятия - пересборка массива с исключением из него более не выбранных в диалоговом окне файлов
Код |
---|
Sub ВыбратьФайлы() t = Timer Dim vFolders(), lCount As Long Dim objFSO As Object, objFolder As Object, objFile As Object Dim sFolder As String, sFiles As String With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Title = "Выбрать файлы выгрузок 1С" 'заголовок окна диалога .Filters.Clear 'очищаем установленные ранее типы файлов .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel ' .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - xls files(Текстовые файлы) .InitialFileName = ActiveWorkbook.Sheets("БД").Range("B2").Value ' = sFolder С:\Temp\Книга1.xlsx" 'назначаем папку отображения и имя файла по умолчанию .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов) If .Show = False Then Exit Sub For lf = 1 To .SelectedItems.Count X = .SelectedItems(lf) 'считываем полный путь к файлу Workbooks.Open X 'открытие книги 'можно также без х 'Workbooks.Open .SelectedItems(lf) ТиповойФайл ' ? открытие остальных файлов папки ' ? постановка отметки о неучастии в массиве ' ? выход с сохранением Next End With Application.ScreenUpdating = True MsgBox "Обновлены остатки" & Chr(10) & Chr(10) & "Первичная дата выгрузки: " & ActiveWorkbook.Sheets("БД").Range("J1").Value & Chr(10) & Chr(10) & "Готово за: " & TimeSerial(0, 0, (Timer - t)) & " сек.", vbInformation + vbMsgBoxSetForeground + vbSystemModal End Sub |