我录制了一个创建数据透视表的宏，但始终出现440运行时错误。我的excel书只包含3张纸，分别是sheet1 sheet2和sheet3。请我想知道为什么出现此错误，它工作正常。我试图在网上搜索错误，但没有解决我的问题。
此行导致错误
设置PTCache = ThisWorkbook.PivotCaches.Add（SourceType：= xlDatabase， SourceData：= PRange）
如果有人有任何建议，请帮助
这是我的代码
Option Explicit
' This function is used to calculate the number of rows
Function lastrow() As Long
Dim ix As Long
ix = ActiveSheet.UsedRange.row - 1 + ActiveSheet.UsedRange.Rows.count
lastrow = ix
End Function
Sub Create_Pivot_table()
' Declaring variables
Dim WSD As Worksheet
Dim WSD1 As Worksheet
Dim PTCache As PivotCache
Dim PT As PivotTable
Dim PF As PivotField
Dim PRange As Range
Dim FinalRow As Long
Dim FinalCol As Long
Set WSD = ThisWorkbook.Worksheets(1)
Set WSD1 = ThisWorkbook.Worksheets(2)
Dim n As Integer
Dim last As Long
Dim ph_flag, sp_flag, up_flag As Boolean
ph_flag = False
sp_flag = False
up_flag = False
last = lastrow() - 1
' Delete any prior pivot tables
For Each PT In WSD1.PivotTables
PT.TableRange2.Clear
Next PT
' Define input area and set up a Pivot Cache
FinalRow = WSD.Cells(Rows.count, 1).End(xlUp).row
FinalCol = WSD.Cells(1, Columns.count).End(xlToLeft).Column
Set PRange = WSD.Cells(1, 1).Resize(FinalRow, FinalCol)
Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=PRange)
' Create the Pivot Table from the Pivot Cache
Set PT = PTCache.CreatePivotTable(TableDestination:=WSD1.Cells(1, 1), TableName:="PivotTable1")
' Turn off updating while building the table
PT.ManualUpdate = False
With PT.PivotFields("DEPT_CODE")
.Orientation = xlRowField
.Position = 1
End With
With PT.PivotFields("MAJR_CODE1")
.Orientation = xlRowField
.Position = 2
End With
With PT.PivotFields("Adviser")
.Orientation = xlRowField
.Position = 3
End With
With PT.PivotFields("CLAS_CODE")
.Orientation = xlColumnField
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
.PivotItems("FR").Position = 1
.PivotItems("SO").Position = 2
.PivotItems("JR").Position = 3
.PivotItems("SR").Position = 4
.PivotItems("PG").Position = 5
.PivotItems("GR").Position = 6
.Position = 1
End With
With PT.PivotFields("STYP_DESC")
.Orientation = xlColumnField
.PivotItems("new").Position = 1
.Position = 2
End With
' Set up the data fields
With PT.PivotFields("ID")
.Orientation = xlDataField
.Function = xlCount
.Position = 1
End With
' Calc the pivot table
PT.ManualUpdate = False
PT.ManualUpdate = True
'***************************************************************************
'Format Pivot Table
PT.ShowDrillIndicators = False
PT.RowAxisLayout xlTabularRow
Sheets("Sheet2").Select
' Shading the first 2 rows in the sheet
ActiveSheet.Rows("2:3").Select
ActiveSheet.Range("A3").Activate
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
' Shading the grand total (row)
PT.PivotSelect "'Row Grand Total'", _
xlDataAndLabel, True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
' Shading the grand total (column)
PT.PivotSelect "'Column Grand Total'", _
xlDataAndLabel, True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
' DEPT_CODE COLUMN
' Putting a thick border the Dept_Code total
' Thick border on the Department
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
PT.PivotSelect "DEPT_CODE[All]", _
xlLabelOnly, True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
' MAJOR_CODE COLUMN
' Thick border on the Major
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
PT.PivotSelect "MAJR_CODE1[All]", _
xlLabelOnly, True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
' ADVISER COLUMN
' Apply to ALL cells thin border
Selection.Borders(xlInsideVertical).LineStyle = xlNone
PT.PivotSelect "Adviser[All]", xlLabelOnly _
, True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
' Thick border for Adviser
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
' CLASS_CODE COLUMNS
' Shading the new columns
PT.PivotSelect "new", xlDataAndLabel, True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
' MAJOR_CODE_TOTAL ROW
' Shading MAJOR_CODE_TOTAL
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
PT.PivotSelect "MAJR_CODE1[All;Total]", _
xlDataAndLabel, True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
' DEPT_TOTAL row
' Shading the DEPT_TOTAL row
PT.PivotSelect "DEPT_CODE[All;Total]", _
xlDataAndLabel, True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
' CLASS_CODE COLUMNS
' Thin All borders
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
For n = 1 To 30
If Cells(2, n) = "SP" Then
sp_flag = True
Exit For
End If
Next
If sp_flag Then
PT.PivotSelect "FR:SP", xlDataAndLabel, _
True
End If
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
PT.PivotSelect "new", xlDataAndLabel, True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
' MAJOR_CODE TOTAL ROW
' Apply a thick border
PT.PivotSelect "MAJR_CODE1[All;Total]", _
xlDataAndLabel, True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
' DEPT_TOTAL ROW
' Apply a thick border
PT.PivotSelect "DEPT_CODE[All;Total]", _
xlDataAndLabel, True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
' This is for the Grand Total
Dim last1 As Long
last1 = lastrow() - 1
'Columns("R:R").Select
Range("R1:R" & last1).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'***************************************************************************
'copy pivot to new sheet
'Sheets("Sheet3").Select
'Selection.Clear
'Sheets("Sheet1").Select
Sheets("Sheet3").Select
Sheets("Sheet3").UsedRange.Clear
ActiveSheet.Range("A1").Select
Sheets("Sheet2").Select
ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True
Selection.Copy
Sheets("Sheet3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Rows(1).Delete
Range("A1:A2").Select
Selection.Merge
ActiveCell.FormulaR1C1 = "Department"
Range("A1:A2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Bold = True
Range("B1:B2").Select
Selection.Merge
ActiveCell.FormulaR1C1 = "Major"
Range("B1:B2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Bold = True
Range("C1:C2").Select
Selection.Merge
ActiveCell.FormulaR1C1 = "Adviser"
Range("C1:C2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Bold = True
ActiveSheet.Cells.Select
ActiveSheet.Cells.EntireColumn.AutoFit
End Sub
Sub Rearrange_Col()
Dim n As Integer
Dim m As Integer
n = 0
m = 9
ActiveSheet.Range("D2").Select
Do While n < m
If ActiveCell.Offset(1, 0).Value = "new" Then
' Check the next cell to be cur
If ActiveCell.Offset(1, 1).Value = "cur" Then
' Check the next cell
ActiveCell.Offset(0, 2).Select
End If
Else
'MsgBox "need to insert"
' Check that the value is cur
If ActiveCell.Offset(1, 0).Value = "cur" Then
ActiveCell.EntireColumn.Insert
ActiveCell.Offset(1, 0).Value = "new"
ActiveCell.Offset(0, 2).Select
End If
End If
n = n + 1
Loop
' After rearranging the new and cur delete the extra columns if any
Do While ActiveCell.Value <> "Grand Total"
If ActiveCell.Value <> "Grand Total" Or (ActiveCell.Value = "" And ActiveCell.Offset(0, 1).Value <> "") Then
ActiveCell.EntireColumn.Delete
End If
Loop
End Sub
Private Sub CommandButton1_Click()
UserForm2.Hide
' Create a pivot table
Call Create_Pivot_table
' This sub will rearrange the new and current under the class codes
'Call Rearrange_Col
' This sub will format the table in sheet 3
'Call Format_Table
'MsgBox "Please check the format of the table in Sheet 3!"
End Sub