Доброго времени суток!
Есть код VBA, который копирует выбранные столбцы по их названию в рабочий файл, но проблема в том, что копирует только из одной книги. Необходимо, чтобы макрос копировал выбранные столбцы из двух книг в лист рабочего файла. К примеру, из первого файла столбцы должны располагаться в диапазоне А1:P1, а из второго T1:AI1, с выводом названия файла без расширения для идентификации. Долго бодаюсь с проблемой, никак не могу найти решение. Подскажите, как можно реализовать вышеописанное?
Есть код VBA, который копирует выбранные столбцы по их названию в рабочий файл, но проблема в том, что копирует только из одной книги. Необходимо, чтобы макрос копировал выбранные столбцы из двух книг в лист рабочего файла. К примеру, из первого файла столбцы должны располагаться в диапазоне А1:P1, а из второго T1:AI1, с выводом названия файла без расширения для идентификации. Долго бодаюсь с проблемой, никак не могу найти решение. Подскажите, как можно реализовать вышеописанное?
| Код |
|---|
Sub CopyData()
Dim FD As FileDialog
Dim Kniga As Workbook
Dim i As Integer
For i = 1 To 2
Set FD = Application.FileDialog(msoFileDialogFilePicker)
FD.AllowMultiSelect = False
FD.Filters.Clear
FD.InitialFileName = ThisWorkbook.Path & "\"
FD.Filters.Add "Анализ", "*.xlsd; *.xlsx; *.xlsb"
FD.Show
If FD.SelectedItems.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Kniga = Application.Workbooks.Open(FD.SelectedItems(1))
Call CollectDate(Kniga, i)
Kniga.Close False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Next i
End Sub
Sub CollectDate(Kniga As Workbook, a As Integer)
Dim shFrom As Worksheet, shTo As Worksheet
Dim clColumnNumbers As New Collection, i As Integer, cFrom As Long, cTo As Long
'Columns Имена копируемых столбцов
clColumnNumbers.Add "Заголовок 1"
clColumnNumbers.Add "Заголовок 2"
clColumnNumbers.Add "Заголовок 3"
clColumnNumbers.Add "Заголовок 4"
clColumnNumbers.Add "Заголовок 5"
clColumnNumbers.Add "Заголовок 6"
clColumnNumbers.Add "Заголовок 7"
clColumnNumbers.Add "Заголовок 8"
clColumnNumbers.Add "Заголовок 9 "
clColumnNumbers.Add "Заголовок 10"
clColumnNumbers.Add "Заголовок 11"
clColumnNumbers.Add "Заголовок 12"
clColumnNumbers.Add "Заголовок 13"
clColumnNumbers.Add "Заголовок 14"
clColumnNumbers.Add "Заголовок 15 "
clColumnNumbers.Add "Заголовок 16"
Application.ScreenUpdating = False
Set shFrom = ActiveSheet
Set shTo = ThisWorkbook.Worksheets("DATA")
If a = 1 Then
ThisWorkbook.Worksheets("Data").Range("A1:Q50000").Value = ""
Else
ThisWorkbook.Worksheets("Data").Range("R1:AJ50000").Value = ""
End If
For i = 1 To clColumnNumbers.Count
'Rows(1) - Заголовок в первой строке
If WorksheetFunction.CountIf(shFrom.Rows(1), clColumnNumbers(i)) <> 0 Then
cFrom = WorksheetFunction.Match(clColumnNumbers(i), shFrom.Rows(1), 0)
cTo = cTo + 1
shFrom.Columns(cFrom).Copy shTo.Cells(1, cTo)
End If
Next
Application.ScreenUpdating = True
MsgBox "Готово!", vbInformation
End Sub
|
