Хотите добавить возможность выбора двух и более файлов

Question

Я создал макрос для сопоставления данных из разных файлов Excel в один файл.

Однако теперь я хочу добавить функцию выбора и импорта данных из нескольких файлов одновременно.

Ниже мой макрос:

Sub Import_Data()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim FileCnt As Byte


Call Entry_Point
Set WB1 = ActiveWorkbook
lrpaste = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row + 1
FileToOpen = Application.GetOpenFilename(Title:="Select your file", MultiSelect:=True, FileFilter:="Excel Files(*.xls*), *xls*")
If IsArray(FileToOpen) Then
For FileCnt = 1 To UBound(FileToOpen)
Set OpenBook = Application.Workbooks.Open(Filename:=FileToOpen(FileCnt))
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
lrow = Cells(Rows.Count, lcol).End(xlUp).Row
OpenBook.Sheets(1).Range(("A2"), Cells(lrow, lcol)).Copy WB1.Sheets("Data").Range("A" & lrpaste)

Next FileCnt

End If
OpenBook.Close False

Call Exit_Point
End Sub

Я пробовал, но макрос не работает должным образом. Он выбирает несколько файлов; однако он не копирует данные всех выбранных файлов. Теперь я не понимаю, как заставить макрос делать то же самое, но с несколькими файлами одновременно.

Предыдущий макрос, который принимает по одному файлу за раз:

Sub Import_Data()
Dim FileToOpen As Variant
Dim OpenBook As Workbook



Call Entry_Point
FileFilter:="Excel Files(*.xls*), *xls*")
Set WB1 = ActiveWorkbook
lrpaste = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row + 1
FileToOpen = Application.GetOpenFilename(Title:="Select your file", FileFilter:="Excel Files(*.xls*), *xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
lrow = Cells(Rows.Count, lcol).End(xlUp).Row
OpenBook.Sheets(1).Range(("A2"), Cells(lrow, lcol)).Copy WB1.Sheets("Data").Range("A" & lrpaste)
OpenBook.Close False

End If


Call Exit_Point
End Sub

Answer 1

Я думаю, вам следует поместить lrpaste обновления строки в свой l oop. В противном случае данные будут отменены.

For FileCnt = 1 To UBound(FileToOpen)
    lrpaste = ThisWorkbook.Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row + 1
    Set OpenBook = Application.Workbooks.Open(Filename:=FileToOpen(FileCnt))
    lcol = Cells(2, Columns.Count).End(xlToLeft).Column
    lrow = Cells(Rows.Count, lcol).End(xlUp).Row
    OpenBook.Sheets(1).Range(("A2"), Cells(lrow, lcol)).Copy 
    WB1.Sheets("Data").Range("A" & lrpaste)

Next FileCnt