VBA打開工作簿錯誤

Question

我在Access 2010中有一個VB表單，它將打開一個文件對話框以進行excel選擇。 我將文件路徑作為字符串發送到我的變量：directory（ directory = strPath ），以打開工作簿並將其內容復制到當前工作簿中。 如果您打算一次使用該工具，則效果很好。 當您導入一個文件，然后導入同一目錄中的另一個文件時，會發生錯誤。

---

非工作示例：

選定的C：\\ Desktop \\ File1.xls，導入
選定的C：\\ Desktop \\ File2.xls，導入

錯誤：

運行時錯誤“ 1004”：
名為“ Tool.xlsm”的文檔已經打開。 即使文檔位於不同的文件夾中，也無法打開兩個具有相同名稱的文檔。 要打開第二個文檔，請關閉當前打開的文檔，或重命名其中一個文檔。

---

工作示例（單獨的文件夾）：

選定的C：\\ Desktop \\ File1.xls，導入
選定的C：\\ Desktop \\ 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 = false，則打開的Wb將觸發其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