對象“_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