將幾張紙復制到一個新的工作簿。 但是出現了1004錯誤

Question

我的代碼如下。 我在Excel 2013中搜索了很多有關vba的1004錯誤，然后按照MS的建議在此處打開，另存為並關閉。

有人知道如何解決這個問題嗎？

謝謝。

Sub SaveAs(FilePath As String)

Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet

On Error GoTo Whoa

Application.DisplayAlerts = False

Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add

On Error Resume Next
For Each ws In wbTemp.Worksheets
    ws.Delete
Next

wbTemp.SaveAs FilePath, 51
wbTemp.Close SaveChanges:=True
Set wbTemp = Nothing
Set wbTemp = Application.Workbooks.Open(FilePath)

On Error GoTo 0

For Each ws In thisWb.Sheets
    If ws.Name <> "data" And ws.Name <> "parameters" Then
        ws.Copy After:=wbTemp.Sheets(1)
    End If
Next

wbTemp.Sheets(1).Delete
wbTemp.SaveAs FilePath, 51

LetsContinue:
    Application.DisplayAlerts = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Answer 1

這個怎么樣：

Sub SaveAs(FilePath As String)

Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet

On Error GoTo Whoa

Application.DisplayAlerts = False

Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add

On Error Resume Next
For Each ws In wbTemp.Worksheets
    ws.Delete
Next

wbTemp.SaveAs FilePath, 51
wbTemp.Close SaveChanges:=True
Set wbTemp = Nothing
Set wbTemp = Application.Workbooks.Open(FilePath)

On Error GoTo 0

Dim counter As Integer
counter = 0

For Each ws In thisWb.Sheets
    If ws.Name <> "data" And ws.Name <> "parameters" Then
        ws.Copy After:=wbTemp.Sheets(1)
        counter = counter + 1
        If iCounter Mod 50 = 0 Then
            wbTemp.Close SaveChanges:=True
            Set wbTemp = Nothing
            Set wbTemp = Application.Workbooks.Open(FilePath)
        End If
    End If
Next

wbTemp.Sheets(1).Delete
wbTemp.SaveAs FilePath, 51

LetsContinue:
    Application.DisplayAlerts = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Answer 2

我使用數組復制一次，而不是一張一張地復制工作表：

Dim group As Variant, s As Integer, path As String

ReDim group(0)
For s = 1 To Sheets.Count    'or use "For Each s in ActiveWorkbook.Sheets"
    If Sheets(s).Name Like "string" Then
        group(UBound(group)) = Sheets(s).Name
        ReDim Preserve group(UBound(group) + 1)
    End If
Next s

If Application.CountA(group) > 1 Then
    ReDim Preserve group(UBound(group) - 1)
    Sheets(group).Copy
    ActiveWorkbook.SaveAs path & "Document" & "_" & ".xlsx", FileFormat:=51
    ActiveWorkbook.Close
End If