Question

我有一个包含多个工作表的大型Excel工作簿，其中包含链接到大型PowerPivot源的数据透视表。我想将每个工作表单独保存到工作簿中，仅作为值。

我已经设法在没有数据透视表的工作簿上执行此操作。但是我在这个项目中得到了以下信息。我不想复制每个保存的嵌入数据，因为它很疯狂。任何提示或帮助？

Option Explicit

Sub JhSeparateSave()
    Dim ws As Worksheet
    Dim NewName As String

    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub

    '       Input box to name new file
    NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

    With Application
        .ScreenUpdating = False

        For Each ws In ThisWorkbook.Worksheets
            If ws.Visible = xlSheetVisible Then
                MsgBox ("Copy step 1")
                ws.Copy

                With ActiveWorkbook.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With

                ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewName & "-" & ws.Name
                ActiveWorkbook.Close
                MsgBox ("Saved sheet: " & ws.Name)
            End If
        Next ws

    End With
End Sub

Answer 1

请参阅此示例（经过测试和尝试）。

Option Explicit

Sub JhSeparateSave()
    Dim wbTemp As Workbook
    Dim ws As Worksheet
    Dim NewName As String

    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub

    '~~> Input box to name new file
    NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

    With Application
        .ScreenUpdating = False

        For Each ws In ThisWorkbook.Worksheets
            If ws.Visible = xlSheetVisible Then
                MsgBox ("Copy step 1")
                ws.Copy

                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & ".csv", _
                FileFormat:=xlCSV, CreateBackup:=False

                ActiveWorkbook.Close savechanges:=False

                Set wbTemp = Workbooks.Open(ThisWorkbook.Path & "\" & NewName & ".csv")

                wbTemp.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & "-" & ws.Name, _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

                wbTemp.Close savechanges:=False

                Kill ThisWorkbook.Path & "\" & NewName & ".csv"

                MsgBox ("Saved sheet: " & ws.Name)
            End If
        Next ws

    End With
End Sub

Answer 2

我最终使用的是什么：

Option Explicit

Sub Copier()

Dim ws As Worksheet
Dim wsNew As Worksheet
Dim NewName As String
Dim wsOriginalName As String

'On Error GoTo Errorcatch

If MsgBox("1. Copy to new sheet. 2. Change to values. 3. Move to new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub

'       Input box to name new file
NewName = InputBox("Please Specify the month name of your new workbook", "New Copy")


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False

    'iterate through all worksheets
    For Each ws In ThisWorkbook.Worksheets

        'ignore hidden worksheets
        If ws.Visible = xlSheetVisible Then

            'copy sheet within original workbook
            wsOriginalName = ws.Name
            ws.Copy After:=Sheets("FAQ")

            'switch to copied sheet
            Set wsNew = ActiveSheet

            'convert to values and format
            With wsNew.UsedRange
                .Copy
                .PasteSpecial xlPasteValuesAndNumberFormats
                .PasteSpecial xlPasteFormats
                .Cells(1, 1).Select
            End With

            'save into new workbook
            wsNew.Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "MIS-FY2013-" & NewName & "-" & wsOriginalName
            ActiveWorkbook.Close

            'MsgBox ("going to try to delete: " & wsNew.Name)
            'delete copied sheet
            wsNew.Delete

         End If
     Next ws

End With

End Sub

将包含数据透视表的单独工作表分成仅包含值的单个工作簿

2 个答案: