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

时间：2018-11-09 02:00:33

标签： excel vba

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

1。）可以在我运行它的所有文件上正常工作，除了一个特定文件，它可以正常运行，但不会创建数据透视表，也不会创建图表。

2。）记录的饼图代码来自excel 2013，并且在excel 2010中无法很好地运行（请参见下面的Sub Pichrt），因此我必须在excel 2010中为我的同事创建另一个记录的宏谁仍在使用excel 2010，是否有办法让1个代码同时在2010年和2013年运行，这种情况仅发生在需要创建饼图的部分。任何帮助将不胜感激。对不起，代码太长，大多数记录为我不是专家。  谢谢。

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

1 个答案:

答案 0 :(得分：0)

我尚未检查完整的代码中是否有错误，但是未创建数据透视表可能是由于以下事实：我不知道出于什么原因，必须将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
相关问题
最新问题