LinkBack URL
About LinkBacks
Current page method of pivot field failed
Problem:
Run time error 2147417848 (80010108)
“Current page method of pivot field failed”
My macro ran once perfectly, but each subsequent time Excel freezes up and I have to shut Excel down.
Operating System: Windows 2000 Pro, Excel 2003
Experience: I don’t have much Excel VBA experience – no formal education.
Background:
I designed a pivot table based on a dynamic range (size is usually 5000 rows by 70 columns). My macro creates report sheets based on this pivot table by automatically switching the “page” field, and then copying and pasting the relevant data into new worksheets that are created when the macro is run.
The worksheets are named the same as the page field of the pivot table. Just as an example (not the same fields as my P.T), if page fields are large American cities, and the user wants reports for “Houston” and “Jacksonville”, they select these names from a validated list in the pivot table worksheet (this list is not a part of the pivot table), then start the macro. The macro automatically creates new worksheets that are named “Houston” and “Jacksonville” which contain the report for the city.
Steps Taken:
1) I’ve read the full version of Mike’s xtremeVB thread on “Automating Excel from VB 6.0” which includes MSKB 178510 & MSKB 319832 aritcles. (http://www.xtremevbtalk.com/archive/index.php/t-135815)
2) I’ve followed all the steps outlined in the article, including defining an object for the current instance of Excel, preceeding every function with this object, while using the “Automation Prophylactics” to compile all of my code to ensure there are no calls to a Global Object.
3) Closed this object at the end of my code.
Where I am Now: Excel still freezes everytime I run my code. I cannot select any cells or do anything else.
Thank you very much to anyone who can help me. If this post is in any way improper or in the wrong place, please feel free to correct me.
Code:
Option Explicit
Public IntStartDay As Integer
Public IntEndDay As Integer
Public IntStartMonth As Integer
Public IntEndMonth As Integer
Public StrStartMonth As String
Public StrEndMonth As String
Public CurrentYear As Integer
Public Historical As String
Public oExcel As Excel.Application
Public oWB As Excel.Workbook
Public oWS As Excel.Worksheet
Public oWSLoop As Excel.Worksheet
Public Sub GradeSheets()
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
Set oWB = oExcel.Workbooks("PM#4 - Grades - TPD")
Set oWS = oWB.Worksheets("Grade Sheet Calculator")
oExcel.ScreenUpdating = False
oExcel.Calculation = xlCalculationManual
oWB.Colors(48) = RGB(202, 6, 6)
oWS.Rows("2:1000").Select
oExcel.Selection.EntireRow.Hidden = False
'************** Declare Variables **********************
Dim NumColumns As Integer
Dim StartDate
Dim EndDate
Dim StDate As String
Dim EndDte As String
Dim ActStDate
Dim ActEndDate
Dim x, y As Integer
Dim GradeSheet As String
'*************** Initialize Variables *****************
NumColumns = 2
IntStartDay = Day(oWS.Cells(1, 7).Value)
IntEndDay = Day(oWS.Cells(2, 7).Value)
IntStartMonth = Month(oWS.Cells(1, 7).Value)
IntEndMonth = Month(oWS.Cells(2, 7).Value)
CurrentYear = Year(oWS.Cells(1, 7).Value)
If CurrentYear < 2003 Then
IntStartMonth = Month(oWB.Sheets("Raw Data").Cells(2, 3).Value)
IntEndMonth = Month(oWB.Sheets("Raw Data").Cells(3, 3).Value)
CurrentYear = Year(Now)
End If
StartDate = oWS.Cells(1, 7).Value
EndDate = oWS.Cells(2, 7).Value
ActStDate = oWS.Cells(1, 4).Value
ActEndDate = oWS.Cells(2, 4).Value
StDate = "<" & ActStDate
EndDte = ">" & ActEndDate
'***** Hide Dates That are Outside Of User Selected Date Range ********
oWS.Range("B3").Select
If oWS.Cells(2, 4).Value = "" Then
oExcel.Selection.Group Start:=True, End:=True, By:=1, Periods:=Array(False, _
False, False, True, False, False, False)
Else
oExcel.Selection.Group Start:=StartDate, End:=EndDate, By:=1, Periods:=Array(False, _
False, False, True, False, False, False)
With oWS.PivotTables("Summary").PivotFields("TIMESTAMP")
.PivotItems(StDate).Visible = False
.PivotItems(EndDte).Visible = False
End With
End If
'Application.Run "'PM#4 - Grades - TPD.xls'!CreateSheets"
'
'End Sub
'
'Public Sub CreateSheets()
'********** DECLARE VARIABLES *******
Static a, b, c, aLoop As Integer
Dim TopDataCellRow, LeftmostDataCellCol, NumberofDataColumns As Integer
Dim PM4FirstTagRow, PM4TagColumn, NumberofWorksheets As Integer
Dim UnitsPath As String
Dim Grade As String
Dim GradeNumber As Variant
Dim TopLeftDataCell As String
Dim Average As Range
Dim ExitLoop As Boolean
Dim strAverageAddress As String
Dim intAverageAddress As Integer
Dim KeepGoin As Boolean
Dim LoopCounter As Integer
Dim NumberofMissingColumns As Integer
'************* Create Grade Sheets ***************
LoopCounter = 1002
KeepGoin = False
Do
If oWS.Cells(LoopCounter, 1) = "" Then
Exit Do
Else
KeepGoin = True
End If
oExcel.ScreenUpdating = False ' Disables screen changes
'********** INITIALIZE VARIABLES ******
If oWS.Cells(LoopCounter, 1) = "All" Then
Grade = "(All)"
Else
Grade = Trim(Str(oWS.Cells(LoopCounter, 1))) ' Grade of paper
End If
TopDataCellRow = 6 ' Row of data immediately after headings
LeftmostDataCellCol = 3 ' Column of data immediately after units column (A=1,B=2,C=3,etc)
NumberofDataColumns = 7 ' # of Data Columns Not Including "Avg." column
PM4FirstTagRow = 9 ' Row number of first tag in "Tags" worksheet (PM # 4)
PM4TagColumn = 2 ' Column number of first tag in "Tags" worksheet (PM # 4) - (A=1,B=2,C=3,etc)
UnitsPath = "='[Data Extractor.xls]Tags'!R" ' Excel link to "Tags" worksheet
'*********** CREATE GRADESHEET **
If StrStartMonth = StrEndMonth Then
If IntEndDay - IntStartDay > 25 Then
GradeSheet = Grade & " (" & StrStartMonth & ", " & CurrentYear & ")"
ElseIf IntEndDay - IntStartDay = 7 Then
GradeSheet = Grade & " (" & StrStartMonth & " " & IntStartDay & " - " & StrEndMonth & " " & IntEndDay & ", " & CurrentYear & ")"
Else
End If
ElseIf IntStartMonth < IntEndMonth Then
GradeSheet = Grade & " (" & StrStartMonth & " - " & StrEndMonth & ", " & CurrentYear & ")"
Else
End If
NumberofWorksheets = oWB.Worksheets.Count
oWB.Worksheets.Add After:=oWB.Worksheets(NumberofWorksheets)
oWB.ActiveSheet.Name = GradeSheet
Set oWSLoop = oWB.Worksheets(GradeSheet)
'*********** LINK DESCRIPTIONS *********
GetData oExcel.ThisWorkbook.Path & "\Data Extractor.xls", "Tags", "A8:A150", oWSLoop.Range("A6"), True
' Windows("Data Extractor.xls").Activate
' oExcel.Run "'Data Extractor.xls'!WBActivateHandler"
' Sheets("Tags").Select
' Range("A8:A150").Select
' Selection.Copy
' Windows("PM#4 - Grades - TPD.xls").Activate
' oWSLoop.Range("A6").Select
' oWSLoop.Paste Link:=True
oWB.ActiveSheet.Range("A4").FormulaR1C1 = "Production at Reel (tonnes/day)"
oWSLoop.Range("A4").Select
oExcel.Selection.Font.Bold = True
oExcel.Selection.Font.Italic = True
oWSLoop.Columns("A:A").ColumnWidth = 33.78
oWSLoop.Range("A6").Select
oExcel.Selection.FormatConditions.Delete
oExcel.Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="0"
oExcel.Selection.FormatConditions(1).Font.ColorIndex = 2
oExcel.Selection.Copy
oWSLoop.Range("A7:B150").Select
oExcel.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
oWSLoop.Range("A6").Select
oExcel.Selection.Font.Bold = True
oExcel.Selection.Font.Underline = xlUnderlineStyleSingle
oWSLoop.Columns("B:B").Select
With oExcel.Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
'*********** COPY AND PASTE DATA INTO GRADESHEETS ********
oWS.Select
' To avoid run-time errors set the following property to True.
'ActiveSheet.PivotTables("Summary").CubeFields("GRADE").EnableMultiplePageItems = True
oWB.ActiveSheet.PivotTables("Summary").PivotFields("GRADE").CurrentPage = Grade
aLoop = oExcel.WorksheetFunction.CountIf(oWS.Columns(1), "Average")
If aLoop = 0 Then
oExcel.DisplayAlerts = False
oWB.Worksheets(NumberofWorksheets + 1).Delete
oExcel.DisplayAlerts = True
GoTo LastLine
End If
b = LeftmostDataCellCol
Set Average = oWS.Range("A4")
For a = 1 To aLoop
oWS.Select
' Find "Average" in Column "A"
Set Average = oWS.Columns(1).Find(What:="Average", After:=Average, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
'************* SKIP TO END
oWS.Select
oExcel.ScreenUpdating = True
LastLine:
LoopCounter = LoopCounter + 1
'
Loop While KeepGoin = True
oExcel.Calculation = xlCalculationAutomatic
oExcel.ScreenUpdating = True
'Clean up
Set oWS = Nothing
Set oWSLoop = Nothing
'If Not oWB Is Nothing Then oWB.Close
Set oWB = Nothing
'oExcel.Quit
Set oExcel = NothingEnd Sub
Register To Reply
still its not working..!!!
Bookmarks