将多个工作表复制到新工作簿。但得到1004错误

时间:2016-01-22 06:27:07

标签: excel vba

我的代码如下。我在Excel 2013中搜索了很多关于vba的1004错误,并按照MS建议打开,保存并关闭here

有谁知道如何解决这个问题?

感谢。

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

2 个答案:

答案 0 :(得分:0)

这个怎么样:

Stream<B> streamOfB = combine(LongStreamEx.range(100000).mapToObj(A::new), null).map(B::new);
streamOfB.forEach(System.out::println);

答案 1 :(得分:0)

我使用数组复制一次,而不是逐个复制工作表:

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