將包含數據透視表的工作表單獨分解爲單個工作簿

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 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 

末次

Answer 2

參見該示例（檢測過，並試圖）。

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