_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.ColorInd ex = 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("GR ADE").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

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 DONT 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) IVE READ THE FULL VERSION OF MIKES 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) IVE 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.ColorInd ex = 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("GR ADE").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

If you still have problems with this code, I think the answer *might* be
addressed in the thread titled, "Where else to get help?". See one of the
last posts by me for a summary of the problems/solution that I had.
-Reuel


"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 DONT 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) IVE READ THE FULL VERSION OF MIKES 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) IVE 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.ColorInd ex = 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("GR ADE").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