1

从代码中可以看出，我正在尝试将单个工作簿加载到 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
4

1 回答 1

2

尝试这个：

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并在主代码中嵌入了文件的加载。
但是，Private Sub如果您要在其他Subs.
我已经对此进行了测试，并且效果很好。
如果有部分代码您不理解，只需将其注释掉即可。

于 2013-11-13T07:11:12.153 回答