将所有数据透视表更改为仅值

Question

我正在使用以下代码将启用宏的报告导出到仅包含原始工作簿中某些工作表的 .xls 文件。

Sub exportFile()
Dim sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
dates = Format(Now, "dd-mm-yyyy")
CurrentWorkbookName = ActiveWorkbook.Name
NewWorkbookName = "Friday Commentary " & dates & ".xlsx"
filePath = ActiveWorkbook.Path


Set NewBook = Workbooks.Add
    With NewBook
        .Title = "All Sales"
        .Subject = "Sales"
        .SaveAs Filename:=filePath & "\" & NewWorkbookName  ', FileFormat:=50  '50 = xlExcel12 (Excel Binary Workbook in 2007-2013 with or without macro's, xlsb)
    End With


Workbooks(CurrentWorkbookName).Activate
For Each sh In Worksheets

If sh.Name = "1" Or sh.Name = "2" Or sh.Name = "3" Or sh.Name = "4" Or sh.Name = "5" Or sh.Name = "6" Or sh.Name = "EXPORT" Or sh.Name = "RAW" Then
   Workbooks(CurrentWorkbookName).Sheets(sh.Name).Copy After:=Workbooks(NewWorkbookName).Sheets(Workbooks(NewWorkbookName).Sheets.Count)
   Workbooks(CurrentWorkbookName).Activate
End If

Next


End Sub

1 - 6 的每个工作表都有一个来自相同数据源的数据透视表。当然，我希望这些数据透视表仅作为具有数据透视表格式的值（而不是数据透视表）提取。我如何将其包含在我的宏中？

Answer 1

如果您在一个工作表中有多个数据透视表，它们将出现在集合中

PivotTables

。因此，您可以轻松访问它们并修改它们的属性。

Option Explicit

Public Sub TestMe()

    Dim pt As PivotTable

    For Each pt In Worksheets(1).PivotTables
        pt.RefreshTable
        pt.TableRange2.Copy
        pt.TableRange2.PasteSpecial Paste:=xlPasteValues
    Next pt

    Application.CutCopyMode = False

End Sub

在您的情况下，循环遍历每个工作表并循环遍历工作表中的每个数据透视表，复制并粘贴其

TableRange2

：

TableRange2 返回一个 Range 对象，该对象表示包含整个数据透视表的范围，包括页面字段。只读。

Answer 2

你可以像这样调整你的代码......

Sub exportFile()
Dim NewBook As Workbook, swb As Workbook
Dim ws As Worksheet
Dim dates As String, filePath As String, CurrentWorkbookName As String, NewWorkbookName As String
Dim shNames, sh
Dim pt As PivotTable
Dim x
Dim cellAddress As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set swb = ActiveWorkbook
dates = Format(Now, "dd-mm-yyyy")
CurrentWorkbookName = swb.Name
NewWorkbookName = "Friday Commentary " & dates & ".xlsx"
filePath = swb.Path

shNames = Array(1, 2, 3, 4, 5, 6, "EXPORT", "RAW")
swb.Sheets(1).Select
For Each sh In shNames
    swb.Sheets(sh).Select False
Next sh

ActiveWindow.SelectedSheets.Copy
Set NewBook = ActiveWorkbook

For Each ws In NewBook.Sheets
    On Error Resume Next
    Set pt = ws.PivotTables(1)
    On Error GoTo 0
    If Not pt Is Nothing Then
        cellAddress = pt.TableRange2.Cells(1).Address
        x = pt.TableRange2.Value
        pt.TableRange2.Delete
        ws.Range(cellAddress).Resize(UBound(x, 1), UBound(x, 2)).Value = x
    End If
    Set pt = Nothing
Next ws    

NewBook.SaveAs Filename:=filePath & "\" & NewWorkbookName

swb.Activate
swb.Sheets(1).Select
End Sub

Answer 3

我尝试了您在上面开发的代码，但是在运行代码时，excel 审计针对代码行发出了以下警报： "对于每个 sh In shNames swb.Sheets(sh).选择 False”。 “运行时错误“9”：下标超出范围”