Question

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

当我运行代码时，出现以下错误：

运行时错误＆＃39; 1004＆＃39;
无法访问＆＃39; TestImport.xlsx＆＃39;

你能帮我看看下面的内容有什么问题吗？

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)

用于保存工作簿的VBA - 替换具有相同名称的文件时出错

2 个答案: