将多个工作簿加载到Excel 2010中

从代码中可以看到，我正试图将一个工作簿加载到excel中。 有没有办法让我select多个工作簿并一次性上传，而不是一次又一次地重新打开文件对话框？

Private Sub OpenFileDialogue() strCancel = "N" strWorkbookNameAndPath = Application.GetOpenFilename _ (FileFilter:=strFilt, _ FilterIndex:=intFilterIndex, _ Title:=strDialogueFileTitle) Workbooks.Open strWorkbookNameAndPath End Sub Public strDialogueFileTitle As String Public strFilt As String Public intFilterIndex As Integer Public strCancel As String Public strWorkbookNameAndPath As String Public strWorkbookName As String Public strWorksheetName As String Public Sub CommandButton1_Click() Dim wkbMasterWorkbook As Workbook Dim wksMasterWorksheet As Worksheet Dim wkbImportedWorkbook As Workbook Dim wksImportedWorksheet As Worksheet Dim rngImportCopyRange As Range Application.ScreenUpdating = False Set wkbMasterWorkbook = ThisWorkbook Set wksMasterWorksheet = Sheets("Sheet1") strFilt = "Excel Files (*.xls),*.xls," & _ "CSV Files (*.csv),*.csv," intFilterIndex = 1 strDialogueFileTitle = "Select The Workbook You Want To Import" Call OpenFileDialogue If strCancel = "Y" Then MsgBox ("An Open Error Occurred Importing Your File Selection") Exit Sub End If Set wkbImportedWorkbook = ActiveWorkbook Set wksImportedWorksheet = wkbImportedWorkbook.Sheets("Sheet1") Set rngImportCopyRange = Range(wksImportedWorksheet.Cells(1, 1), Cells(250, 1)).EntireRow rngImportCopyRange.Copy wksMasterWorksheet.Range("A" & Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial Paste:=xlPasteValues, SkipBlanks _ :=False, Transpose:=False wkbMasterWorkbook.Activate Application.DisplayAlerts = False wkbImportedWorkbook.Close Savechanges:=False Application.DisplayAlerts = True wksMasterWorksheet.Activate wksMasterWorksheet.Cells(1, 1).Select Application.ScreenUpdating = True Worksheets("Sheet1").Visible = True End Sub 

Answer 1

尝试这个：

 Private Sub OpenFileDialogue() Dim strWorkbookNameAndPath Dim fileArraySize, i as Long strCancel = "N" strWorkbookNameAndPath = Application.GetOpenFilename _ (FileFilter:=strFilt, _ FilterIndex:=intFilterIndex, _ Title:=strDialogueFileTitle, _ MultiSelect:=True)'add this line which will let you select all the files 'your variable now contains array of filenames fileArraySize = Ubound(strWorkbookNameAndPath, 1) 'count how many files 'loop and open the files For i = 1 to fileArraySize Workbooks.Open strWorkbookNameAndPath(i) Next i 

EDIT1：

 Option Explicit Public strDialogueFileTitle As String Public strFilt As String Public intFilterIndex As Integer Public strCancel As String Public strWorkbookNameAndPath As String Public strWorkbookName As String Public strWorksheetName As String Public Sub CommandButton1_Click() Dim wkbMasterWorkbook As Workbook Dim wksMasterWorksheet As Worksheet Dim wkbImportedWorkbook As Workbook Dim wksImportedWorksheet As Worksheet Dim rngImportCopyRange As Range 'added this to enhance performance and eliminate alert when you close an opened file. With Application .ScreenUpdating = False .DisplayAlerts = False End With On Error Goto errhandler 'added this just in case something came up so you won't be stuck Set wkbMasterWorkbook = ThisWorkbook Set wksMasterWorksheet = wkbMasterWorkbook.Sheets("Sheet1") strFilt = "Excel Files (*.xls),*.xls," & _ "CSV Files (*.csv),*.csv," intFilterIndex = 1 strDialogueFileTitle = "Select The Workbook You Want To Import" strCancel = "N" If strCancel = "N" Then Dim strWorkbookNameAndPath Dim fileArraySize, lrow, i As Long strCancel = "N" strWorkbookNameAndPath = Application.GetOpenFilename _ (FileFilter:=strFilt, _ FilterIndex:=intFilterIndex, _ Title:=strDialogueFileTitle, _ MultiSelect:=True) 'add this line which will let you select all the files 'your variable now contains array of filenames fileArraySize = UBound(strWorkbookNameAndPath, 1) 'count how many files 'loop and open the files For i = 1 To fileArraySize 'open the file Set wkbImportedWorkbook = Workbooks.Open(strWorkbookNameAndPath(i)) Set wksImportedWorksheet = wkbImportedWorkbook.Sheets("Sheets1") 'copy all contents and paste on masterfile With wksImportedWorksheet lrow = .Range("A" & .Rows.Count).End(xlUp).Row Set rngImportCopyRange = .Range("A1:A" & lrow).EntireRow rngImportCopyRange.Copy wksMasterWorksheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues End With 'close the source file wkbImportedWorkbook.Close Set wkbImportedWorkbook = Nothing Set wksImportedWorksheet = Nothing Next i Else MsgBox "An Open Error Occurred Importing Your File Selection" Exit Sub End If With Application .ScreenUpdating = True .DisplayAlerts = True End With Exit Sub errhandler: MsgBox "An unexpected error occurred!" & vbNewLine & _ "Error No.: " & Err.Number & vbNewLine & _ "Description: " & Err.Description, vbExclamation, "Error Notification" End Sub 

我删除了Private Sub并在主代码中embedded加载文件。
但是如果你打算在其他的Subs使用它，你总是可以提取这个部分并将其设为Private Sub 。
我已经testing了这个，它工作正常。
如果有部分代码不理解，请将其注释掉。