VBA打开工作簿错误

Question

我在Access 2010中有一个VB窗体，打开一个文件对话框来进行Excel选择。我将文件路径作为字符串发送到我的变量：目录（directory = strPath）以打开工作簿并将其内容复制到我当前的工作簿中。如果你打算一次使用这个工具，那工作正常。这是当你导入一个文件，然后另一个在相同的目录中发生错误。

---

不工作的例子：

选择C：\桌面\ File1.xls，进口
选择C：\桌面\ File2.xls，进口

错误：

Run-time error '1004':
A document with the name 'Tool.xlsm' is already open. You cannot open two documents with the same name, even if the documents are in different folders. To open the second document, either close the document that's currently open, or rename one of the documents.

---

工作实例（单独文件夹）：

选择C：\桌面\ File1.xls，进口
选择C：\桌面\ TestFolder \ File2.xls，进口

---

Public Sub CommandButton1_Click() 
    Dim intChoice As Integer 
    Dim strPath As String 
    Application.EnableCancelKey = xlDisabled 
    'only allow the user to select one file 
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False 
    'make the file dialog visible to the user 
    intChoice = Application.FileDialog(msoFileDialogOpen).Show 
    'determine what choice the user made 
    If intChoice <> 0 Then 
     'get the file path selected by the user 
     strPath = Application.FileDialog(_ 
      msoFileDialogOpen).SelectedItems(1) 
     'print the file path to sheet 1 
     TextBox1 = strPath 
    End If 

End Sub 

Public Sub CommandButton2_Click() 
    Dim directory As String, FileName As String, sheet As Worksheet, total As Integer 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 


    directory = strPath 
    FileName = Dir(directory & "*.xls") 


    Do While FileName <> "" 
    Workbooks.Open (directory & FileName) 

    For Each sheet In Workbooks(FileName).Worksheets 
     total = Workbooks("Tool.xlsm").Worksheets.Count 
     Workbooks(FileName).Worksheets(sheet.name).Copy _ 
     after:=Workbooks("Tool.xlsm").Worksheets(total) 
    Next sheet  

    Workbooks(FileName).Close  

    FileName = Dir() 

    Loop 

    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True  
    Application.EnableCancelKey = xlDisabled 
    Application.DisplayAlerts = False 

End Sub 

在调试模式下它不喜欢

Workbooks.Open (directory & FileName) 

任何建议，以消除此错误？

Answer 1

首先，在目录和FileName之间，我假设有一个“\”。

其次，简单地检查工作簿已经打开：

dim wb as workbook 

err.clear 
on error resume next 
set wb = Workbooks (FileName) 'assuming the "\" is not in FileName 
if err<>0 or Wb is nothing then 'either one works , you dont need to test both 
    err.clear 
    set wb= Workbooks.Open (directory & FileName) 
end if 
on error goto 0 

，如果你不使用application.enableevents =假，你打开白平衡将触发其workbook_open事件！

Answer 2

我想发布工作代码，也许它将在未来帮助某人。再次感谢那些留下评论的人。

此代码将打开一个文件对话框，允许用户选择1个excel文件，然后将所选文件中的所有工作表复制到当前工作簿中。

Public Sub CommandButton1_Click() 
Dim intChoice As Integer 
Application.EnableCancelKey = xlDisabled 
'only allow the user to select one file 
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False 
'make the file dialog visible to the user 
intChoice = Application.FileDialog(msoFileDialogOpen).Show 
'determine what choice the user made 
If intChoice <> 0 Then 
    'get the file path selected by the user 
    strPath = Application.FileDialog(_ 
     msoFileDialogOpen).SelectedItems(1) 
    'print the file path to textbox1 
    TextBox1 = strPath 
End If 

End Sub 

Public Sub CommandButton2_Click() 
Dim directory As String, FileName As String, sheet As Worksheet, total As Integer 
Dim wb As Workbook 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

Err.Clear 
On Error Resume Next 
Set wb = Workbooks(FileName) 'assuming the "\" is not in FileName 
If Err <> 0 Or wb Is Nothing Then 'either one works , you dont need to test both 
    Err.Clear 
    Set wb = Workbooks.Open(directory & TextBox1) 
End If 
On Error GoTo 0  


    FileName = Dir(directory & TextBox1)  

    Do While FileName <> "" 
    Workbooks.Open (directory & TextBox1) 

    For Each sheet In Workbooks(FileName).Worksheets 
     total = Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets.Count 
     Workbooks(FileName).Worksheets(sheet.name).Copy _ 
     after:=Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets(total) 
    Next sheet 

    Workbooks(FileName).Close 

    FileName = Dir() 

    Loop 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.EnableCancelKey = xlDisabled 
Application.DisplayAlerts = False 


End Sub