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

<强> 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并在主代码中嵌入了文件加载但是，如果您要在其他Private Sub中使用该部分，则可以始终提取该部分并将其设为Subs。
我测试了这个并且它工作正常如果您不理解代码的某些部分，请将其注释掉。

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

1 个答案: