将包含数据透视表的工作表分离到只有值的单个工作簿中答案

【问题标题】：Separate worksheets containing pivot tables into individual workbooks with only values将包含数据透视表的工作表分离到只有值的单个工作簿中
【发布时间】：2012-04-30 02:45:41
【问题描述】：

我有一个大型 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

【问题讨论】：

与其做“复制”和“粘贴值”，不如直接保存为csv？
我不想要 csv... 我想要一个可以发送给其他同事的 xlsx
还有一个选项，暂时保存为csv，保存为xlsx后立即删除csv？

标签： excel vba copy-paste pivot-table

【解决方案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

【讨论】：

感谢您的努力。然而，这并不是最理想的。运行 ws.copy 后，我的整个 20mb 数据透视表源将被临时复制，这需要很长时间。我想我将探索在原始笔记本中创建新工作表的策略，复制到该工作表中，仅更改为值+格式，然后将其移动到新工作簿。

【解决方案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

结束子

【讨论】：