[okshef]

Нашел вот такой код (http://www.excelworld.ru/forum/2-2898-1). Нужно только "допилить под себя"

читать дальше »

Код:

Sub Импорт()
     Dim BazaWb As Workbook    'файл для сбора данных
     Dim SelectedItem As String    'имя файла выбранного в диалоге

     MsgBox "Внимание!!!Необходимо выбрать уже заполненный файл.  следуйте инструкции!"

     'вызываем диалог выбора папки с файлами отчёта
     With Application.FileDialog(msoFileDialogFilePicker)
         .Title = "Выберите файл для отчета"    'надпись в окне диалога
         'путь по умолчанию к папке /где расположен исходный файл
         .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xlsx*"
         .AllowMultiSelect = False    'запрет выбора нескольких файлов
         If .Show = False Then GoTo ErrShow:
         SelectedItem = .SelectedItems(1)    'при обработке нескольких - удалить
     End With
     With Application
         'отлючаем системные сообщения
         .DisplayAlerts = False
         'отлючаем обновление экрана - это убыстрит работу макроса
         .ScreenUpdating = False
         'включаем ручной пересчёт формул - это убыстрит работу макроса
         .Calculation = xlManual
         'отключаем отображения окон на панели задач на время выполнения макроса
         .ShowWindowsInTaskbar = False
     End With
     'присваиваем переменной BazaWb ссылку на общий файл
     Set BazaWb = ThisWorkbook
     With Workbooks.Open(SelectedItem)
         On Error Resume Next
         'операции с открытой книгой
        .....
       'здесь ваш код
        .....
         .Close False    'закрываем книгу
     End With
        .....
       'здесь ваш код
        .....
     On Error GoTo 0
 ErrShow:
     With Application
         'включаем автоматический пересчёт формул, который отключили в начале макроса
         .Calculation = xlAutomatic
         'включаем отображения окон на панели задач, которое отключали в начали макроса
         .ShowWindowsInTaskbar = True
         'включаем обновление экрана, который отключили в начале макроса
         .ScreenUpdating = True
         .DisplayAlerts = False
     End With
End Sub