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 returns a Range object that represents the range containing the entire PivotTable report, including page fields. Read-only.

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

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

2 个答案: