将工作表拆分为单个文件夹中的工作簿

时间:2014-01-17 17:56:00

标签: excel-vba vba excel

我试图通过将单个工作簿中的每个工作表分离出来来创建多个Excel工作簿:

 Sub Splitbook()
 MyPath = ThisWorkbook.Path
 For Each sht In ThisWorkbook.Sheets
 sht.Copy
 '(I got an error here-copy method of worksheet class failed)
 ActiveSheet.Cells.Copy
 ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
 ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
 ActiveWorkbook.SaveAs _
 Filename:=MyPath & "\" & sht.Name & ".xls"
 ActiveWorkbook.Close savechanges:=False
 Next sht
 End Sub  

我为不同的工作簿使用了相同的代码并且它工作正常但我现在看到工作表类的复制方法失败错误。

有人可以解释为什么以及如何解决这个问题吗?

2 个答案:

答案 0 :(得分:0)

为了执行所描述的任务,您的代码会有一些复杂问题。我修改了您的代码,以便从活动工作簿中的所有工作表中创建单独的工作簿。

Sub Splitbook()
    Dim CurWb As Workbook, NewWb As Workbook
    Dim MyPath As String
    MyPath = ActiveWorkbook.Path
    Set CurWb = ActiveWorkbook

    Application.ScreenUpdating = False

    'Loops through all sheets in active workbook
    For Each CurWs In CurWb.Worksheets
        'Copy sheet to new workbook
        CurWb.Sheets(CurWs.Name).Copy After:=Workbooks.Add.Sheets(1)
        Set NewWb = ActiveWorkbook

        'Removes empty sheets, saves workbook and closes workbook
        Application.DisplayAlerts = False
        For Each NewWs In NewWb.Worksheets
            If NewWs.Name <> CurWs.Name Then NewWs.Delete
        Next NewWs
        NewWb.SaveAs Filename:=MyPath & "\" & CurWs.Name & ".xls", FileFormat:=56
        NewWb.Close SaveChanges:=False
        Application.DisplayAlerts = True
    Next CurWs

    Application.ScreenUpdating = True
End Sub

答案 1 :(得分:0)

我修改了您的代码以检查复制的工作表是否可见。请试一试,让我知道结果。

Sub Splitbook()
    MyPath = ThisWorkbook.Path
    For Each sht In ThisWorkbook.Sheets

        If sht.Visible = True Then
            sht.Copy
            '(I got an error here-copy method of worksheet class failed)
            ActiveSheet.Cells.Copy
            ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
            ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
            ActiveWorkbook.SaveAs _
                    Filename:=MyPath & "\" & sht.Name & ".xls"
            ActiveWorkbook.Close savechanges:=False
        End If
    Next sht
End Sub