Отдельные рабочие листы, содержащие сводные таблицы, в отдельные рабочие книги только со значениями

У меня есть одна большая книга 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

excel pivot-table copy-paste vba
person Julien    schedule 30.04.2012    source источник
comment
Вместо того, чтобы копировать и вставлять значения, почему бы не сохранить их напрямую как csv?   -  person Siddharth Rout    schedule 30.04.2012
comment
мне не нужен csv... мне нужен xlsx, который я могу отправить другим коллегам   -  person Julien    schedule 30.04.2012
comment
Еще один вариант, временно сохранить его как csv и сразу после сохранения как xlsx удалить csv?   -  person Siddharth Rout    schedule 30.04.2012

Ответы (2)


arrow_upward
0
arrow_downward

См. этот пример (ПРОВЕРЕНО И ПРОВЕРЕНО).

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
person Siddharth Rout    schedule 30.04.2012
comment
Спасибо за усилия. Однако это не совсем оптимально. как только вы запускаете ws.copy, весь мой исходный код сводной таблицы размером 20 МБ временно копируется, что занимает очень много времени. я думаю, что собираюсь изучить стратегию создания нового листа в исходной записной книжке, копирования в этот лист, изменения только на значения + формат, а затем перемещения его в новую книгу. - person Julien; 03.05.2012

arrow_upward
0
arrow_downward

что я в итоге использовал:

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

Конец сабвуфера

person Julien    schedule 04.06.2012