0

大きな PowerPivot ソースにリンクされたピボット テーブルを含む複数のワークシートを含む 1 つの大きな Excel ワークブックがあります。各ワークシートをワークブックに個別に値としてのみ保存した​​いと考えています。

ピボットテーブルのないワークブックでこれを行うことができました。しかし、このプロジェクトでは次のメッセージが表示されます。非常に遅いため、保存ごとに埋め込まれたデータをコピーしたくありません。ヒントやヘルプはありますか？

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
4

2 に答える 2

0

私が最終的に使用したもの：

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

サブ終了

于 2012-06-04T08:14:53.857 に答える
0

この例を参照してください ( TESTED AND TRIED )。

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
于 2012-04-30T03:39:19.223 に答える