对象'_Workbook'的VBA方法'SaveAs'失败，但仅在一台计算机上

Question

所以我编写了一个运行良好的程序，我添加了对另一个数据文件的额外支持，该文件在我的计算机上测试良好，但在我的一位同事计算机上，代码不断抛出错误，将 save as 方法称为原因。

我发现的另一个线程表明日期格式可能是问题所在，但这在保存过程中似乎没有意义。

它以正确的名称保存文件，甚至询问我是否要替换同名的文件，然后在创建保存文件后调试器抛出错误。

（我第一次在她的机器上运行程序时也没有发生，它在代码中进一步抛出错误，当我重新运行断点时，它开始在我编写的保存函数中抛出错误）

另一个线程提到活动工作簿可能会导致问题，使用 ThisWorkbook 可能会更好，我想我很困惑为什么它可以在我的机器上运行，而不是在她的机器上运行。会是什么问题？

无论如何这里是抛出错误的代码块，在此先感谢他的帮助！

ActiveWorkbook.SaveAs 是抛出错误的行，在它生成文件之后...

Private Sub SaveAsNew(parseName As String, path As String)
Dim sheetToCopy As String
sheetToCopy = "Sheet1"
Worksheets(sheetToCopy).Copy
With ActiveWorkbook
     .SaveAs path & "\" & parseName & "StandardForm.xlsx"
     .Close savechanges:=False
End With
End Sub

Answer 1

将工作表导出到新工作簿

• 如果发生错误，立即窗口中会显示一条消息 (Ctrl+G)。

Option Explicit

Private Sub SaveAsNew(ByVal ParseName As String, ByVal DestPath As String)
    Const ProcName As String = "SaveAsNew"
    Dim Success As Boolean
    On Error GoTo ClearError ' enable error-trapping
    
    ' Source - copy a worksheet
    Const sName As String = "Sheet1"
    ' Destination - save a single-worksheet workbook
    Const dRightName As String = "StandardForm.xlsx"
    
    ' Determine the destination folder path.
    Dim dFolderPath As String: dFolderPath = DestPath
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    
    ' Validate the existence of the destination folder path.
    If Len(Dir(dFolderPath)) = 0 Then
        MsgBox "The path '" & dFolderPath & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    ' Reference the source workbook.
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    
    ' Attempt to reference the source worksheet.
    Dim sws As Worksheet
    On Error Resume Next ' defer error-trapping
        Set sws = swb.Worksheets(sName)
    On Error GoTo ClearError ' re-enable error-trapping
    
    ' Validate the existence of the source worksheet.
    If sws Is Nothing Then
        MsgBox "The worksheet '" & sName & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    ' Return a copy of the source worksheet in a new single-worksheet workbook.
    sws.Copy
    
    ' Reference this workbook, the destination workbook.
    Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
    
    ' Write the destination file path to a variable
    Dim dFilePath As String: dFilePath = dFolderPath & ParseName & dRightName
    
    ' Save the destination workbook (file).
    Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    ' If you don't overwrite, when you press 'No' or 'Cancel',
    ' an error will occur.
    dwb.Close SaveChanges:=False ' it's already saved
    
    ' Validate the success.
    Success = True

ProcExit:
    On Error Resume Next ' defer error-trapping (to avoid an endless loop)
        If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
        ' Inform.
        If Success Then
            MsgBox "Worksheet exported.", vbInformation
        Else
            MsgBox "Something went wrong.", vbCritical
        End If
    On Error GoTo 0 ' disable error-trapping
    
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub