Имеется файл test.xlsm с макросом, который должен обрабатывать выбранные .xls файлы пользователем. И копировать из файлов определенные ячейки в табличку на первом листе test.xlsm.
1. Вызываю циклом выбранные файлы, но не могу понять открыть этот файл И скопировать оттуда нужную информацию в общею таблицу в файле test.xlsm Например ячейки B7 B9 B10 из открытого файла в b2 c2 d2 файла test.xlsm
Прикладываю файл примера с загружаемыми файлами.
Здравствуйте, прошу помощи в доработке процедуры.
Имеется файл test.xlsm с макросом, который должен обрабатывать выбранные .xls файлы пользователем. И копировать из файлов определенные ячейки в табличку на первом листе test.xlsm.
1. Вызываю циклом выбранные файлы, но не могу понять открыть этот файл И скопировать оттуда нужную информацию в общею таблицу в файле test.xlsm Например ячейки B7 B9 B10 из открытого файла в b2 c2 d2 файла test.xlsm
Sub Выбор_нескольких_файлов() Dim i As Long '!!! Dim il As Long Dim a()
'диалог для выбора файла Dim fd As FileDialog 'объектная переменная диалог выбора выбора файлов и папок Set fd = Application.FileDialog(msoFileDialogFilePicker) 'тип диалога выбор файла
fd.AllowMultiSelect = True 'включить выбор множества файлов fd.Filters.Clear 'очистить фильтры типов файлов, если он запомнил их fd.Filters.Add "Файлы Excel-я", "*.xls;*.xlsx" 'выбор только файлов екселя
fd.Show 'открыт диалог
If fd.SelectedItems.Count = 0 Then 'если не выбрали файл то "ошибка" MsgBox "Не выбрали файл" Exit Sub End If
For i = 1 To fd.SelectedItems.Count 'перебор имён файлов With GetObject(fd.SelectedItems(i)) 'открываем a = .Sheets(1).[b5:b10].Value 'берём данные в массив .Close False 'закрываем без сохранения изменений (их правда и нет) End With il = Range("A" & Rows.Count).End(xlUp).Row + 1 'определяем последнюю строку Cells(il, 1) = a(1, 1) ' в неё и перекладываем данные из массива Cells(il, 2) = a(3, 1) Cells(il, 3) = a(5, 1) Cells(il, 4) = a(6, 1) Next i
'форматирую всю таблицу With Range("A1").CurrentRegion .Borders.ColorIndex = 1 'сетка черного цвета .Columns.AutoFit 'автовыравнивание With .Rows(1) 'для 1 строки заголовка .Font.Bold = True 'жирный шрифт .Interior.ColorIndex = 38 'цвет фона .HorizontalAlignment = xlCenter 'по центру End With End With
Application.ScreenUpdating = True
End Sub
[/vba]
Вариант: [vba]
Код
Sub Выбор_нескольких_файлов() Dim i As Long '!!! Dim il As Long Dim a()
'диалог для выбора файла Dim fd As FileDialog 'объектная переменная диалог выбора выбора файлов и папок Set fd = Application.FileDialog(msoFileDialogFilePicker) 'тип диалога выбор файла
fd.AllowMultiSelect = True 'включить выбор множества файлов fd.Filters.Clear 'очистить фильтры типов файлов, если он запомнил их fd.Filters.Add "Файлы Excel-я", "*.xls;*.xlsx" 'выбор только файлов екселя
fd.Show 'открыт диалог
If fd.SelectedItems.Count = 0 Then 'если не выбрали файл то "ошибка" MsgBox "Не выбрали файл" Exit Sub End If
For i = 1 To fd.SelectedItems.Count 'перебор имён файлов With GetObject(fd.SelectedItems(i)) 'открываем a = .Sheets(1).[b5:b10].Value 'берём данные в массив .Close False 'закрываем без сохранения изменений (их правда и нет) End With il = Range("A" & Rows.Count).End(xlUp).Row + 1 'определяем последнюю строку Cells(il, 1) = a(1, 1) ' в неё и перекладываем данные из массива Cells(il, 2) = a(3, 1) Cells(il, 3) = a(5, 1) Cells(il, 4) = a(6, 1) Next i
'форматирую всю таблицу With Range("A1").CurrentRegion .Borders.ColorIndex = 1 'сетка черного цвета .Columns.AutoFit 'автовыравнивание With .Rows(1) 'для 1 строки заголовка .Font.Bold = True 'жирный шрифт .Interior.ColorIndex = 38 'цвет фона .HorizontalAlignment = xlCenter 'по центру End With End With