返回首页
当前位置: 主页 > Excel教程 > Excel VBA教程 >

Excel数据透视表-如何实现打印

时间:2017-04-29 21:33来源:Office教程学习网 www.office68.com编辑:麦田守望者

数据透视表 -- 打印


       打印 数据透视表页字段中的每个数据项
      下面的代码将能够实现打印页字段中的每个数据项的功能(假定为一个页字段).请使用打印预览测试. 准备打印时, 请去掉 ActiveSheet.PrintOut代码前的单引号, 并在代码ActiveSheet.PrintPreview前添加一个单引号. 
Sub PrintPivotPages()
 '打印数据透视表一个页字段下的每个数据项
 '假设只有一个页字段存在
On Error Resume Next
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Set pt = ActiveSheet.PivotTables.Item(1)
  For Each pf In pt.PageFields
    For Each pi In pf.PivotItems
      pt.PivotFields(pf.Name).CurrentPage = pi.Name
'      ActiveSheet.PrintOut  '使用这个代码打印
      ActiveSheet.PrintPreview  '使用这个代码预览
    Next
  Next pf
End Sub     
  
      打印数据透视表页字段下每个数据项的透视图
      下面的代码将能够实现打印页字段中的每个数据项的透视图功能(假定为一个页字段).请使用打印预览测试. 准备打印时, 请去掉 ActiveSheet.PrintOut代码前的单引号, 并在代码ActiveSheet.PrintPreview前添加一个单引号.  
Sub PrintPivotCharts()
 'prints a chart for each item in the page field
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Set pt = ActiveChart.PivotLayout.PivotTable
  For Each pf In pt.PageFields
    For Each pi In pf.PivotItems
      pt.PivotFields(pf.Name).CurrentPage = pi.Name
'      ActiveSheet.PrintOut
      ActiveSheet.PrintPreview  '打印预览测试
    Next
  Next pf
End Sub     
  
      打印数据透视表的每个页数据项 – 多个页字段
      下面代码将完成打印数据透视表页数据项的每个组合. 如果 PrintFlag 不设置为 true, 描述信息将被写入PageItemList工作表.
Option Compare Text
Public mrow As Integer
Public PrintFlag As Boolean
'============
Sub PrintAllPages()
'from code posted by Tom Ogilvy
'September 5 2004
Dim holdSettings
Dim ws As Worksheet
Dim wsPT As Worksheet
Set ws = Worksheets("PageItemList") 'sheet for page items
Set wsPT = Worksheets("Pivot") 'sheet with PivotTable
mrow = 0
If MsgBox("Print?", vbYesNo, "Print?") = vbYes Then
  PrintFlag = True
Else
  PrintFlag = False
  MsgBox "Page field items will be listed on sheet " & ws.Name
End If
If Not PrintFlag Then
  ws.Cells(1, 1).CurrentRegion.Clear
End If
Set PvtTbl = wsPT.PivotTables(1)
wsPT.Activate
If PvtTbl.PageFields.Count = 0 Then
  MsgBox "The PivotTable has no Pages"
  Exit Sub
End If
With PvtTbl
ReDim holdSettings(1 To .PageFields.Count)
I = 1
For Each PgeField In .PageFields
  holdSettings(I) = PgeField.CurrentPage.Name
  I = I + 1
  PgeField.CurrentPage = PgeField.PivotItems(1).Name
Next PgeField
End With
 
PvtPage = 1
PvtItem = 1
DrillPvt oTable:=PvtTbl, Ipage:=PvtPage, wksht:=ws
I = 1
For Each PgeField In PvtTbl.PageFields
 PgeField.CurrentPage = holdSettings(I)
  I = I + 1
Next PgeField
 
End Sub
'=============
Sub DrillPvt(oTable, Ipage, wksht)
'Debug.Print "in DrillPvt, page:=" & Ipage & " Page Item: " & _
'  oTable.PageFields(Ipage).CurrentPage & " " & mrow
If Ipage = oTable.PageFields.Count Then
 With oTable
  For I = 1 To .PageFields(Ipage).PivotItems.Count
   .PageFields(Ipage).CurrentPage = _
   .PageFields(Ipage).PivotItems(I).Name
   mrow = mrow + 1
   slist = ""
   For j = 1 To .PageFields.Count
     slist = slist & .PageFields(j).CurrentPage & " "
   Next j
 '  Debug.Print slist
   If PrintFlag Then
''    ActiveSheet.PrintOut  'print the sheet
    ActiveSheet.PrintPreview  'preview -- for testing
   Else
    For j = 1 To .PageFields.Count
     wksht.Cells(mrow, j).Value = _
      .PageFields(j).CurrentPage.Name
    Next j
   End If
  Next I
 End With
 For I = oTable.PageFields.Count - 1 To 1 Step -1
   For j = 1 To oTable.PageFields(I).PivotItems.Count
     If oTable.PageFields(I).CurrentPage = _
      oTable.PageFields(I).PivotItems(j).Name Then
        CurrItem = j
        Exit For
     End If
   Next j
   If CurrItem <> oTable.PageFields(I).PivotItems.Count Then
      oTable.PageFields(I).CurrentPage = _
        oTable.PageFields(I).PivotItems(CurrItem + 1).Name
      Ipage = I + 1
      DrillPvt oTable, Ipage, wksht
   Else
     If I <> 1 Then
       oTable.PageFields(I).CurrentPage = _
        oTable.PageFields(I).PivotItems(1).Name
     Else
       Exit Sub
     End If
   End If
 Next I
Else
 DrillPvt oTable, Ipage + 1, wksht
End If
End Sub     

------分隔线----------------------------
标签(Tag):EXCEL数据透视表
------分隔线----------------------------
推荐内容
猜你感兴趣