VBA保存工作簿 - 用同名文件替換文件的錯誤

Question

我使用下面的VBA代碼自動保存文件，但允許用戶選擇文件位置和名稱。我有一個固定的文件名，我希望用戶使用，例如：TestImport.xlsx，但我需要一些代碼來允許他們選擇特定PC上的路徑。他們將每週運行這個例程，所以他們可能會有一個以前版本的工作簿，並且名稱完全相同，因此他們必須回答對話框提示以替換文件。

當我運行代碼，我得到以下錯誤：

Run-time error '1004'
Cannot access 'TestImport.xlsx'

你能不能幫我看看這個問題與下面的內容是什麼？

Dim fd As FileDialog, fillName As String 

    On Error GoTo ErrorHandler 

    Set fd = Application.FileDialog(msoFileDialogSaveAs) 

    If fd.Show = True Then 
     If fd.SelectedItems(1) <> vbNullString Then 
      fillName = fd.SelectedItems(1) 
     End If 
    Else 
     'Stop Code Execution for Null File String 
     End 
    End If 

    saveFileAs = fillName 

    'Cleanup 
    Set fd = Nothing 

    Windows("MeritImport.xlsx").Activate 
    Application.ActiveWorkbook.SaveAs Filename:=fillName, _ 
     FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 


    Exit Sub 

ErrorHandler: 
    Set fd = Nothing 
    MsgBox "Error " & Err & ": " & Error(Err) 

Answer 1

I have a fixed filename that I want the user to use, for example: TestImport.xlsx

然後讓用戶只能選擇文件夾的位置，並用它來保存文件。例如

Sub Sample() 
    Dim Ret 
    Dim flname As String 

    Ret = BrowseForFolder("C:\") 

    If Not Ret = "" Then 
     If Right(Ret, 1) <> "\" Then Ret = Ret & "\" 

     flname = Ret & "TestImport.xlsx" 

     MsgBox flname 
     ' 
     '~~> Rest of your code 
     ' 
    End If 
End Sub 

Function BrowseForFolder(Optional OpenAt As Variant) As Variant 
    Dim ShellApp As Object 

    Set ShellApp = CreateObject("Shell.Application"). _ 
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 

    On Error Resume Next 
    BrowseForFolder = ShellApp.self.Path 
    On Error GoTo 0 

    Set ShellApp = Nothing 

    Select Case Mid(BrowseForFolder, 2, 1) 
    Case Is = ":" 
     If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 
    Case Is = "\" 
     If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 
    Case Else 
     GoTo Invalid 
    End Select 

    Exit Function 
Invalid: 
    BrowseForFolder = False 
End Function 

當您嘗試使用flname覆蓋該文件（如果已經有一個副本），那麼你會得到一個提示。用戶可以選擇「是」或「否」。如果你不想給用戶一個選擇，那麼你可以使用Application.DisplayAlerts = False

注意：如果副本打開，那麼你不能覆蓋它。如果你嘗試這樣做，它會給你一個錯誤。

Answer 2

而不是使用

Set fd = Application.FileDialog(msoFileDialogSaveAs) 

使用

Set fd = Application.FileDialog(msoFileDialogFolderPicker) 

，然後創建您的文件名作爲

fillname = fillName & Application.PathSeparator & "TestImport.xlsx" 

---

要停止顯示的消息如「你確定你想要替換此文件「，請使用Application.DisplayAlerts = False。

---

爲了確保用戶還沒有在文件中的當前Excel版本中打開（這是很難測試，它是不是在另一個實例中打開，或由其他用戶，等等），你可以使用如下代碼：

'Check to ensure that TestImport.xlsx isn't currently open 
On Error Resume Next 
Dim wb As Workbook 
Set wb = Workbooks("TestImport.xlsx") 
On Error GoTo 0 
If Not wb Is Nothing Then 
    MsgBox "Please close 'TestImport.xlsx'" 
    End 
End If 

---

最終的代碼可能看起來像：

Dim fd As FileDialog, fillName As String, wb As Workbook 

    'Check to ensure that TestImport.xlsx isn't currently open 
    On Error Resume Next 
    Set wb = Workbooks("TestImport.xlsx") 
    On Error GoTo 0 
    If Not wb Is Nothing Then 
     MsgBox "Please close 'TestImport.xlsx'" 
     End 
    End If 

    On Error GoTo ErrorHandler 

    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 
    fd.Title = "File Save" ' to change the title from "Browse" to "File Save" 
    If fd.Show = True Then 
     If fd.SelectedItems(1) <> vbNullString Then 
      fillName = fd.SelectedItems(1) 
     Else 
      End 
     End If 
    Else 
     'Stop Code Execution for Null File String 
     End 
    End If 
    fillName = fillName & Application.PathSeparator & "TestImport.xlsx" 

    'Cleanup 
    Set fd = Nothing 

    Windows("MeritImport.xlsx").Activate 
    Application.DisplayAlerts = False 
    Application.ActiveWorkbook.SaveAs Filename:=fillName, _ 
             FileFormat:=xlOpenXMLWorkbook, _ 
             CreateBackup:=False 
    Application.DisplayAlerts = True 
    Exit Sub 

ErrorHandler: 
    Set fd = Nothing 
    MsgBox "Error " & Err & ": " & Error(Err)