Импорт нескольких листов Excel из выбираемого местоположения

Question

Я пытаюсь сделать кнопку в Excel, чтобы вызвать экран для пользователя, чтобы выбрать местоположение папки и добавить все его файлы Excel в рабочие листы.

Sub Getsheets() 
Path = GetFolder("N:\", "Select an Input Folder") 
Filename = Dir(Path & "*.xlsm") 
Do While Filename <> "" 
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True 
For Each Sheet In ActiveWorkbook.Sheets 
Sheet.Copy After:=ThisWorkbook.Sheets(1) 
Next Sheet 
Application.DisplayAlerts = False 
Workbooks(Filename).Close 
Filename = Dir() 
Loop 
End Sub 

Function GetFolder(strPath As String, fldSt As String) As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = fldSt 
     .AllowMultiSelect = False 
     .InitialFileName = strPath 
     If .Show <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

Это то, что я до сих пор, если я не включить функцию getfolder, я могу retrive всех файлов Excel в указанной папке, но как только я поставил функцию, ничего не происходит. Как исправить эту проблему?

Answer 1

Файл filedialog возвращает путь без конечного «\» (зависит от платформы). Вам нужно добавить в конце «\» вручную перед поиском «* .xlsm»

Так третья строка кода будет:

Filename = Dir(Path & Application.PathSeparator & "*.xlsm") 

EDIT Есть другие ссылки на Пути, где PathSeparator должен быть добавлен.

На самом деле, лучше всего программно взять ссылку на книгу при ее открытии. Кроме того, лучше объявлять переменные (используйте «Option Explicit» в 1-й строке модуля для обеспечения этого).

Вот ваш код, обновляется в соответствии с выше мысли:

Sub Getsheets() 
    Dim Path As String, Filename As String, Sheet As Worksheet, wkBook As Workbook 
    Path = GetFolder("N:\", "Select an Input Folder") & Application.PathSeparator 
    Filename = Dir(Path & "*.xlsm") 
    Do While Filename <> "" 
     Set wkBook = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True) 
     For Each Sheet In wkBook.Sheets 
      Sheet.Copy After:=ThisWorkbook.Sheets(1) 
     Next Sheet 
     Application.DisplayAlerts = False 
     wkBook.Close 
     Filename = Dir() 
    Loop 
End Sub 

Я испытал это на папку с 5 .xlsm файлов в нем; он работал нормально.