对象“_Workbook”的方法“SaveAs”在其他计算机上失败

Question

我有一个代码将一个工作簿拆分为将近 500 个。此代码从一个工作簿运行并打开另一个工作簿进行拆分。 在我的电脑上，这每次都可以正常工作。 在其他人身上，代码将首先停在 ws.copy 行。 他们停止代码并重新开始。 该代码将适用于前 180-220 张，然后弹出“另存为”错误。根据在线阅读，我认为这是内存问题或计时错误。为了解决这个问题，我添加了一个等待函数无济于事。任何帮助将不胜感激。下面的代码供参考。

Sub Splitbook()

Dim MyFile As String
MyFile = Sheets("Steps").Range("C6")

Windows(MyFile).Activate

Dim xPath As String

xPath = Application.ActiveWorkbook.Path

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each ws In ActiveWorkbook.Sheets

ws.Copy

Name = ws.Range("C15").Value

Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & Name & ".xlsx"

Application.ActiveWorkbook.Close False

newHour = Hour(Now())

newMinute = Minute(Now())

newSecond = Second(Now()) + 1

waitTime = TimeSerial(newHour, newMinute, newSecond)

Application.Wait waitTime

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

ActiveWorkbook.Close SaveChanges:=False

MsgBox ("Split Complete. Press Ok to finish."), vbOKOnly, ("Thank you for your Patience.")

End Sub

编辑

根据您的反馈，我更新了代码如下：

Sub Splitbook()

Dim MyFile As String

Dim wb As Workbook

MyFile = Sheets("Steps").Range("C6")

Set wb = Application.Workbooks(MyFile)

Windows(MyFile).Activate

Dim Loc As String

Loc = Application.ActiveWorkbook.Path

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each ws In wb.Sheets

ws.Copy

Name = ws.Range("C15").Value

Application.ActiveWorkbook.SaveAs Filename:=Loc & "\" & Name & ".xlsx"

DoEvents

Application.ActiveWorkbook.Close False

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True


wb.Close SaveChanges:=False

MsgBox ("Split Complete. Press Ok to finish."), vbOKOnly, ("Thank you for your Patience.")

End Sub

Answer 1

因此ActiveWorkbook 、 Activate 、 Select和ActiveSheet的危险。 它们可能不是您所期望的，代码的位置很重要。 如果您从Module运行， Sheet或ThisWorkbook也会有所不同。 如果您要从模块运行，则需要限定位置 - 您正在引用的Workbook 、 Sheet或Range 。 当您通过复制没有目的地的工作表来创建新工作簿时，该工作簿将暂时成为活动工作簿，同时您需要锚定到您的起始文件。

Sub Splitbook()

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Dim OrigWb As Workbook
    Set OrigWb = ThisWorkbook 'or Set OrigWb = Workbooks("SplitFile") or some filename if not ThisWorkbook

    Dim xPath As String
    xPath = OrigWb.Path

    For Each ws In OrigWb.Sheets
        NewFileName = ws.Range("C15").Value
        ws.Copy
        With ActiveWorkbook
            .SaveAs Filename:=xPath & "\" & NewFileName & ".xlsx"
            .Close False
        End With
        MsgBox ("Split Complete. Press Ok to finish."), vbOKOnly, ("Thank you for your Patience.")
    Next ws

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

除非Range("C15")为空白或无效，否则此方法有效且将有效。 该文件不会保存，您也不会知道，因为您关闭了警报。 您可能需要先检查范围是否为空。

If Not IsEmpty(ws.Range("C15").Value Then