Did you find a solution to this problem? I have this same error code while
programming VB Excel macros doing lots of cutting and pasting (importing raw
datafiles into a common summary file & graphing the data). I note that
solomon_monkey has this same error code in a post labled HEEEEEEELP on 7/5/05.


"stock11r" wrote:

>
> _PROBLEM:_ [/B]
> 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
> [B]Set oWS = Nothing
> Set oWSLoop = Nothing
> 'If Not oWB Is Nothing Then oWB.Close
> Set oWB = Nothing
> 'oExcel.Quit
> Set oExcel = Nothing*End Sub
>
>
> --
> stock11r
> ------------------------------------------------------------------------
> stock11r's Profile: http://www.excelforum.com/member.php...o&userid=26251
> View this thread: http://www.excelforum.com/showthread...hreadid=395464
>
>