vba - 复制工作表的数据源

Question

我正在尝试将三张工作表(两张是数据透视表，一张是这些数据透视表的源数据)从一个工作簿复制到一个新工作簿。

下面的代码将所需的工作表复制到新工作簿并保存(修改 original ):

Sub ExportFile()
    Dim NewName As String
    Dim nm As Name
    Dim ws As Worksheet

    With Application
        .ScreenUpdating = False
        On Error GoTo ErrCatcher

        ' Array of sheets to copy
        Sheets(Array("sourcedata", "pivot", "pivot2")).Copy
        On Error GoTo 0

        For Each ws In ActiveWorkbook.Worksheets
            ws.Cells.Copy
            ' Paste sheets
            ws.[A1].PasteSpecial

            ' Remove external links, hyperlinks and hard-code formulas
            ws.Cells.Hyperlinks.Delete
            Application.CutCopyMode = False

            ' Select A1 on sheet
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select

        ' Save it in the same directory as original and close
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\export.xls"
        ActiveWorkbook.Close SaveChanges:=False

        .ScreenUpdating = True
    End With
    Exit Sub

ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub

但是，当我打开新工作簿时，数据透视表中的数据源仍指向原始工作簿。我的同事解释说，这是因为表格是一张一张地复制的，而不是一组复制的，并建议将表格复制为一个范围。我将如何将工作表复制为一个范围，或者将数据源更改为新复制的工作表是否更简单？

Answer 1

您可以通过复制整个工作表而不是单元格来简化创建新工作簿部分。

至于将新轴点指向新源，您需要做的就是从 PivotSource 中删除外部引用。格式为 [oldworkbook]sourcedata!A1:Z100所以你只需要截断括号内的部分。 (这不是一个通用的解决方案，但在这种情况下，我们同时复制数据源选项卡和数据透视选项卡，因此我们知道新工作簿将有一个具有相同名称、相同大小、相同范围等的数据选项卡作为原始工作簿)

Sub CopyPivotsAndData()

Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim ws As Excel.Worksheet
Dim pt As Excel.PivotTable
Dim s As String
Dim r As Integer

    Set wb = ThisWorkbook
    wb.Worksheets(Array("sourcedata", "pivot", "pivot2")).Copy
    Set wbNew = ActiveWorkbook

    Set ws = wbNew.Worksheets("pivot")
    Set pt = ws.PivotTables(1)
    s = pt.SourceData
    r = InStr(s, "]")
    pt.SourceData = Mid(s, r + 1)

    'repeat for pivot2, or loop if you have many worksheets

    wbNew.SaveAs "newworkbookname.xlsx"

    'close or clean up as necessary

End Sub