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

Question

正如您从代码中看到的那样，我正在尝试将单个工作簿加载到 excel 中。有没有办法让我选择多个工作簿并一次性上传它们，而不是一次又一次地重新打开文件对话框？

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

编辑1：

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并将文件的加载嵌入到主代码中。
但是，如果您要在其他Subs中使用它，您可以随时提取该部分并使其成为Private Sub。
我已经对此进行了测试，它工作正常。
如果代码中有部分您不理解，请将其注释掉。