Excel VBA 不执行数据透视表和饼图的代码答案

【问题标题】：Excel VBA does not execute code for Pivot table and Pie ChartExcel VBA 不执行数据透视表和饼图的代码
【发布时间】：2018-11-09 14:58:07
【问题描述】：

我有这段代码，当我单击按钮时，我可以格式化 Excel 数据，过滤它，删除不必要的数据，然后在新工作表上创建数据透视表和图表，并将工作表重命名为摘要。我遇到的问题是：

1.) 这适用于我运行它的所有文件，除了一个特定文件，它运行时没有错误，但它不会创建数据透视表，也不会创建图表。

2.) 饼图代码是从 excel 2013 记录的，它在 excel 2010 中无法正常运行，（请参阅下面的 Sub Pichrt），所以我必须在 excel 2010 中为我的同事创建另一个记录的宏谁仍在使用 excel 2010，有没有办法让 2010 和 2013 都运行 1 个代码，这只发生在需要创建饼图的部分。任何帮助将不胜感激。对不起，代码太长了，大部分都是因为我不是专家而记录的。谢谢。

Sub OpenIt()
myFile = Application.GetOpenFilename(, , "Browse forWorkbook")
Workbooks.Open myFile
Call KeepOnlyAtSymbolRows
End Sub

Sub KeepOnlyAtSymbolRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long

Set ws = ActiveWorkbook.Sheets("Abstraction Data Extract")

lastRow = ws.Range("J" & ws.Rows.Count).End(xlUp).Row

Set rng = ws.Range("J1:J" & lastRow)

   ' filter and delete all but header row
With rng
    .AutoFilter Field:=1, Criteria1:="<>*Yes*"
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With

   ' turn off the filters
ws.AutoFilterMode = False
lastRow = ws.Range("I" & ws.Rows.Count).End(xlUp).Row

Set rng = ws.Range("I1:I" & lastRow)

   ' filter and delete all but header row
With rng
    .AutoFilter Field:=1, Criteria1:="<>*C=Complete*"
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With

   ' turn off the filters
ws.AutoFilterMode = False
Call Format
End Sub
Sub Format()
Dim Found As Range
Dim LastRowColumnA As Long
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim lastRow As Long
Dim LastCol As Long


Rows("1:1").Select
Selection.AutoFilter

Set Found = Rows(1).Find(what:="Comments", LookIn:=xlValues, 
lookat:=xlWhole)
If Not Found Is Nothing Then Found.Value = "Differences"

Columns("N:O").Select
Selection.Style = "Currency"
Columns("N:N").Select
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 1), TrailingMinusNumbers:=True
Columns("O:O").Select
Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 1), TrailingMinusNumbers:=True

Columns("F:F").Select
Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "m/d/yyyy"

Columns("L:L").Select
Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "m/d/yyyy"

Columns("G:G").Select
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "m/d/yyyy"

LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
Range("S2:S" & LastRowColumnA).Formula = "=RC[-5]-RC[-4]"

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True


Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("Abstraction Data Extract")

'Define Data Range
lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(lastRow, LastCol)

    'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="OnePivotTable")

   'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="OnePivotTable")

  'Insert Row Fields
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("DRG Mismatch 
Reason")
.Orientation = xlRowField
.Position = 1
'.Caption = "Mismatch Reason"
.PivotItems("(blank)").Visible = False
ActiveSheet.PivotTables("OnePivotTable").CompactLayoutRowHeader = "Mistmatch 
Reason"
On Error GoTo 0
End With


  'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Final DRG 
Reimbursement")
.Orientation = xlDataField
.Position = 1
.Calculation = xlPercentOfTotal
.NumberFormat = "0.00%"
.Name = "Percent of Total"
End With

On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Final DRG 
Reimbursement")
.Orientation = xlDataField
.Position = 2
.Function = xlCount
.NumberFormat = "#,##0"
.Name = "Count"
End With

   'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Final DRG 
Reimbursement")
.Orientation = xlDataField
.Position = 3
.Function = xlSum
.NumberFormat = "$#,##0"
.Name = "Final DRG Reimbursement "
End With

   'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Working DRG 
Reimbursement")
.Orientation = xlDataField
.Position = 4
.Function = xlSum
.NumberFormat = "$#,##0"
.Name = "Working DRG Reimbursement "
End With

   'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Differences")
.Orientation = xlDataField
.Position = 5
.Function = xlSum
.NumberFormat = "$#,##0"
.Name = "Differences "
End With

   'Format Pivot
TableActiveSheet.PivotTables("SalesPivotTable").ShowTableStyleRowStripes = 
True
ActiveSheet.PivotTables("SalesPivotTable").TableStyle2 = "PivotStyleMedium9"

Sheets("PivotTable").Name = "Summary"
Call PiChrt
End Sub
Sub PiChrt()

Range("B4:C10").Select
ActiveSheet.Shapes.AddChart2(251, xlPie).Select
ActiveChart.SetSourceData Source:=Range("Summary!$B$2:$G$11")
ActiveSheet.Shapes("Chart 1").IncrementLeft -143.25
ActiveSheet.Shapes("Chart 1").IncrementTop 50.25
ActiveChart.SetElement (msoElementDataLabelBestFit)
ActiveChart.SetElement (msoElementDataLabelInsideEnd)
ActiveChart.FullSeriesCollection(1).DataLabels.Select
With Selection.Format.TextFrame2.TextRange.Font
    .BaselineOffset = 0
    .Fill.Visible = msoTrue
    .Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
    .Fill.ForeColor.TintAndShade = 0
    .Fill.ForeColor.Brightness = 0
    .Fill.Transparency = 0
    .Fill.Solid
End With
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Chart 1").ScaleHeight 1.7239585156, msoFalse, _
    msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 1").ScaleHeight 1.1208461201, msoFalse, _
    msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 1").ScaleWidth 1.0416666667, msoFalse, _
    msoScaleFromTopLeft
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
ActiveWorkbook.ShowPivotTableFieldList = False

End Sub

【问题讨论】：

标签： excel vba

【解决方案1】：

我尚未检查您的完整代码是否存在错误，但未创建数据透视表可能是因为，我不知道出于什么原因，必须将 PivotRange 编码为 STRING 格式，使用 R1C1 参考样式。

这给出了：

Dim PRange As string

'Define data range 
lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column

PRange = DSheet.Name & "!" & DSheet.Range(DSheet.Cells(1,1), DSheet.Cells(LastRow, LastCol)).Address(ReferenceStyle:=x1A1)

'Define Pivot Cache
'rest of your code

【讨论】：

谢谢 Lambik，我做到了，但仍然没有在该特定文件中创建数据透视表和图表，其他都很好..
我尝试在示例工作簿中运行代码，但没有结果。由于我没有原始数据，TS很难。用于创建数据透视表的数据、工作表名称和表名称是否始终完全相同？
我可以向您发送 2 个虚拟数据，其中 1 个在文件中有效，另一个在文件中无效，是的，工作表的名称始终相同。数据通过不同的设施下载，但标题和列始终相同。非常感谢。
你好兰比克。你上面的提示解决了我的问题，我在我的代码中将我的 PRange 声明为 Range，所以我按照你的代码建议将它更改为 String，然后我插入了 (PRange = DSheet.Name & "!" & DSheet.Range(DSheet .Cells(1,1), DSheet.Cells(LastRow, LastCol)).Address(ReferenceStyle:=x1A1)) 按照您的建议并删除（Set PRange = DSheet.Cells(1, 1).Resize(lastRow, LastCol) ）从我的代码，所以我会检查你的建议是否被接受，但我上面的第二个问题，我如何在上面的代码中重新编写 Sub Pichrt 以适用于 excel 2010 和 2013，目前仅适用于 2013。跨度>
约翰，感谢您接受答案。在代码之前使用 OPTION EXPLICIT 始终是一个好习惯，这会强制您声明所有变量，在这种情况下可能会返回错误，提醒您有问题。由于我多年没有在 excel 2010 中工作，我也不知道 2010/2013 或带有 Excel2010 的电脑之间的区别，恐怕我无法帮助你。对不起。