VBA 保存工作簿 - 替换同名文件时出错

Question

我正在使用下面的 VBA 代码自动保存文件，但允许用户选择文件位置和名称。我有一个希望用户使用的固定文件名，例如：TestImport.xlsx，但我需要一些代码来允许他们选择特定 PC 上的路径。他们将每周运行此例程，因此他们可能拥有同名的先前版本的工作簿，因此他们必须回答对话框提示以替换文件。

当我运行代码时，我收到以下错误：

运行时错误“1004”
无法访问“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

我有一个希望用户使用的固定文件名，例如：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)