Solved: pivot table issue

[SeanJ]

I am having issue with the creating pivot table. when I run the program the 1st time I am gettimg the pivot table. but when I try running it again I get different error and this time it is Run-time error 91.

This is the line that I am getting the error on.

Set ws = ActiveWorkbook.ActiveSheet

Private Sub cmdProduce_Click()
Dim xl As Object
Dim wb As Object
Dim ws As Object

Dim pst As Task
Dim t As Task

Dim MyStart As Date
Dim MyEnd As Date
Set xl = CreateObject("Excel.Application")
Set pst = ActiveProject.ProjectSummaryTask
If From_Date.Value > To_Date.Value Then
MsgBox "The 'From date' must be less then the 'To date'", vbInformation
Exit Sub
End If
xl.Visible = True
ProduceWBSReport xl, ws
MakePivotTable ws
Set xl = Nothing
Me.Hide
Unload Me
End Sub

Sub MakePivotTable(ws As Object)
Dim PT As PivotTable
Dim strField As String
Dim PTCache As PivotCache
Dim PRange As Range
Set ws = ActiveWorkbook.ActiveSheet


Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
Range("A1").CurrentRegion.Address)
' Create the pivot table
ActiveWorkbook.Sheets.Add
Set ws = ActiveWorkbook.ActiveSheet
ws.Name = "Month"
Set PT = ws.PivotTables.Add( _
PivotCache:=PTCache, _
TableDestination:=Range("A3"))
' Define the layout of the pivot table
' Add the fields
With PT
.PivotFields("LOO").Orientation = xlRowField
.PivotFields("LOO").Position = 1

.PivotFields("Location").Orientation = xlRowField
.PivotFields("Location").Position = 2
.PivotFields("FY").Orientation = xlColumnField
.PivotFields("FY").Position = 1
.PivotFields("Month").Orientation = xlColumnField
.PivotFields("Month").Position = 2
.PivotFields("Month").Orientation = xlDataField
'no field captions
.DisplayFieldCaptions = False
End With
End Sub

[Bob Phillips]

What sort of Excel object is a task?

Where is the ProduceWBSReport procedure?

[SeanJ]

here is the whole code. I am getting information from project (that part is not and issue it is the creating the pivot table I am banging my head against. It is something stupid I know.

Option Explicit

Private Sub cmdProduce_Click()
Dim xl As Object
Dim wb As Object
Dim ws As Object

Dim pst As Task
Dim t As Task

Dim MyStart As Date
Dim MyEnd As Date
Set xl = CreateObject("Excel.Application")
Set pst = ActiveProject.ProjectSummaryTask
If From_Date.Value > To_Date.Value Then
MsgBox "The 'From date' must be less then the 'To date'", vbInformation
Exit Sub
End If
xl.Visible = True
ProduceWBSReport xl, ws
MakePivotTable ws
Set xl = Nothing
Me.Hide
Unload Me
End Sub
Public Sub ProduceWBSReport(xl As Object, ws As Object)

Dim wb As Object

Dim NameCol As Integer
Dim OLCol As Integer
Dim SumCol As Integer
Dim CurRow As Integer
Dim CurCol As Integer
Dim IncludeAccruals As Boolean

Dim TaskName As String
Dim Summary As String
Dim OL As Integer
Dim sp As String
Dim txtMonth As String



Dim txtLocation As String
Dim tmpLoc As String
Dim tmpLoo As String
Dim txtLoo As String
Dim txtFY As String
Dim LocArry() As Variant ' array that holds the unique items
Dim array1() As Variant

Dim CountLoc As Integer
Dim vntAnswer As Variant

Dim p As Project
Dim t As Task

Dim ConsolidatedPlan As Boolean

On Error GoTo ErrorHandler

'Set the active project
Set p = ActiveProject

'Add a new workbook
Set wb = xl.Workbooks.Add()
xl.AlertBeforeOverwriting = False
xl.DisplayAlerts = False


'Delete default sheets 2 & 3
xl.Sheets("Sheet2").Delete
xl.Sheets("Sheet3").Delete

Set ws = xl.ActiveSheet

ws.Name = "From_To Main Data"



txtLocation = "YPG"
CountLoc = 1


i = 1

'Populate the sheets with data
CurRow = 2
For Each t In p.Tasks
If t.OutlineCode4 <> "" Then
If t.Start >= From_Date.Value And t.Start <= To_Date.Value Then

'txtFY = (MONTH(t.Start)>9,YEAR(t.Start)+1,YEAR(t.Start))
txtFY = Year(t.Start) + IIf(t.Start > DateSerial(Year(t.Start), 9, 30), 1, 0)
'Year(t.Start) -
'Breaking down Location
tmpLoc = Left(Trim(t.OutlineCode4), 3)
If tmpLoc = "YPG" Then
txtLocation = "YPG"
Else
txtLocation = t.OutlineCode4
End If

' Breaking down Atn
tmpLoo = InStr(t.OutlineCode9, ".")
'tmpAtn = Left(t.OutlineCode9, Find(".", t.OutlineCode9) - 1)
If tmpLoo = 4 Then
txtLoo = Left(Trim(t.OutlineCode9), 3)
ElseIf tmpLoo = 11 Then
txtLoo = Left(Trim(t.OutlineCode9), 10)
Else
txtLoo = t.OutlineCode9
End If

'These fields appear on every report.
'Outline Level and Summary will be removed after formatting.
CurCol = 1
ws.Cells(CurRow, CurCol) = t.ID
CurCol = CurCol + 1
ws.Cells(CurRow, CurCol) = t.Name
CurCol = CurCol + 1

'The fields below are optional


ws.Cells(CurRow, CurCol) = FormatDateTime(t.Start, vbShortDate)
CurCol = CurCol + 1
ws.Cells(CurRow, CurCol) = txtFY
CurCol = CurCol + 1
ws.Cells(CurRow, CurCol) = Format(t.Start, "mmm")
CurCol = CurCol + 1
ws.Cells(CurRow, CurCol) = FormatDateTime(t.Finish, vbShortDate)
CurCol = CurCol + 1
ws.Cells(CurRow, CurCol) = txtLoo
CurCol = CurCol + 1
ws.Cells(CurRow, CurCol) = txtLocation
CurRow = CurRow + 1
End If
End If
Next t




'===== Page formatting for Title Row and Column Widths, Alignment

'Set the Title Row to BOLD
ws.Rows(1).Select
xl.Selection.Font.Bold = True

CurCol = 1
'Task ID
ws.Columns(CurCol).ColumnWidth = 4
ws.Columns(CurCol).HorizontalAlignment = xlRight
ws.Cells(1, CurCol) = "ID"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom

'Task Name
CurCol = CurCol + 1
ws.Columns(CurCol).ColumnWidth = 40

ws.Cells(1, CurCol) = "Task Name"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom
'Start

CurCol = CurCol + 1
ws.Columns(CurCol).ColumnWidth = 10
ws.Columns(CurCol).HorizontalAlignment = xlRight
ws.Columns(CurCol).VerticalAlignment = xlTop
ws.Columns(CurCol).WrapText = True

ws.Cells(1, CurCol) = "Start Date"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom

'FY

CurCol = CurCol + 1
ws.Columns(CurCol).ColumnWidth = 10
ws.Columns(CurCol).HorizontalAlignment = xlRight
ws.Columns(CurCol).VerticalAlignment = xlTop
ws.Columns(CurCol).WrapText = True

ws.Cells(1, CurCol) = "FY"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom



'Month

CurCol = CurCol + 1
ws.Columns(CurCol).ColumnWidth = 10
ws.Columns(CurCol).HorizontalAlignment = xlRight
ws.Columns(CurCol).VerticalAlignment = xlTop
ws.Columns(CurCol).WrapText = True

ws.Cells(1, CurCol) = "Month"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom

'Finish

CurCol = CurCol + 1
ws.Columns(CurCol).ColumnWidth = 10
ws.Columns(CurCol).HorizontalAlignment = xlRight
ws.Columns(CurCol).VerticalAlignment = xlTop
ws.Columns(CurCol).WrapText = True

ws.Cells(1, CurCol) = "Finish Date"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom
'LOO

CurCol = CurCol + 1
ws.Columns(CurCol).ColumnWidth = 25
ws.Columns(CurCol).HorizontalAlignment = xlRight
ws.Columns(CurCol).VerticalAlignment = xlTop
ws.Columns(CurCol).WrapText = True
ws.Cells(1, CurCol) = "LOO"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom


'Location

CurCol = CurCol + 1
ws.Columns(CurCol).ColumnWidth = 25
ws.Columns(CurCol).HorizontalAlignment = xlRight
ws.Columns(CurCol).VerticalAlignment = xlTop
ws.Columns(CurCol).WrapText = True
ws.Cells(1, CurCol) = "Location"
ws.Cells(1, CurCol).HorizontalAlignment = xlCenter
ws.Cells(1, CurCol).VerticalAlignment = xlBottom



'Move Cursor to Top/Left
ws.Cells(1, 1).Select

With xl.ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "For Official Use Only"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "For Official Use Only"
End With



Exit Sub
ErrorHandler:
MsgBox Err.Description, vbInformation, "zzz"

End Sub
Sub MakePivotTable(ws As Object)
Dim PT As PivotTable
Dim strField As String
Dim PTCache As PivotCache
Dim PRange As Range
Set ws = ActiveWorkbook.ActiveSheet


Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
Range("A1").CurrentRegion.Address)
' Create the pivot table
ActiveWorkbook.Sheets.Add
Set ws = ActiveWorkbook.ActiveSheet
ws.Name = "Month"
Set PT = ws.PivotTables.Add( _
PivotCache:=PTCache, _
TableDestination:=Range("A3"))
' Define the layout of the pivot table
' Add the fields
With PT
.PivotFields("LOO").Orientation = xlRowField
.PivotFields("LOO").Position = 1

.PivotFields("Location").Orientation = xlRowField
.PivotFields("Location").Position = 2
.PivotFields("FY").Orientation = xlColumnField
.PivotFields("FY").Position = 1
.PivotFields("Month").Orientation = xlColumnField
.PivotFields("Month").Position = 2
.PivotFields("Month").Orientation = xlDataField
'no field captions
.DisplayFieldCaptions = False
End With
End Sub

[Bob Phillips]

That part may not be the issue, and maybe we don't need that to recreate the problem, but that is putting the onus on us to do that work,et it up, and reproduce it. Far better if you would post us a file and tell us how to reproduce the problem.

[SeanJ]

Hey XLD I try something and I need your help. I just created the Excel spreadsheet from MS Project. I found and modified this code. http://www.vbaexpress.com/forum/showthread.php?t=18581

Public Sub MakePivotTable(xl As Object, ws As Object)
Dim PTCache As PivotCache
Dim Pt As PivotTable
Dim this As Worksheet

xl.ScreenUpdating = False

xl.DisplayAlerts = False
On Error Resume Next

ws("PivotSheet").Delete

On Error GoTo 0
xl.DisplayAlerts = True

' Create a PivotCashe
Set PTCache = xl.PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:=Range("A1").CurrentRegion.Address)

' Create the Pivot Table from the Cache
Set Pt = PTCache.CreatePivotTable( _
TableDestination:="", _
TableName:="PivotTable2")

ws.Name = "PivotSheet"

' Add the fields
With Pt
.PivotFields("LOO").Orientation = xlRowField
.PivotFields("LOO").Position = 1

.PivotFields("Location").Orientation = xlRowField
.PivotFields("Location").Position = 2
.PivotFields("FY").Orientation = xlColumnField
.PivotFields("FY").Position = 1
.PivotFields("Month").Orientation = xlColumnField
.PivotFields("Month").Position = 2
.PivotFields("Month").Orientation = xlDataField
'no field captions
.DisplayFieldCaptions = False
End With

Application.ScreenUpdating = True
End Sub

When I place your code olny in the spreadsheet and only change .pivot fields it run eveytime, but when I run it in MS Project 2003 and used the modified code above I get run time error 438 at Create a PivotCashe section. Now the data is being dumped into Excel 2007. :banghead:

It is funny I can run the code all day in excel by itself but it gets screwy in MS Project 2003. :bug: :help

[SeanJ]

I have narrowed it down to this area

SourceData:=Range("A1").CurrentRegion.Address)

[SeanJ]

I got it working here is the code I used:

Sub MakePivotTable(xl As Object, ws As Object)
'this code was modified from http://bytes.com/topic/access/answers/
'868388-create-pivot-table-using-vba-access-2007-a
Dim CurrentSheet As Variant
Dim Datasheet As Variant
Dim LastRowNumber As Integer

LastRowNumber = ws.Cells(xl.Rows.Count, 1).End(xlUp).Row


Dim PTable As Variant
'AppExcel.ActiveWorkbook.Sheets
Set Datasheet = xl.Sheets("From To Main Data")
Set CurrentSheet = xl.Worksheets.Add

With CurrentSheet
.Name = "Analysis"
End With


With xl.ActiveWorkbook.PivotCaches
With .Add(SourceType:=xlDatabase, SourceData:=Datasheet.Range("A1:H" & LastRowNumber))
Set PTable = .CreatePivotTable(TableDestination:=CurrentSheet.Range("A1"), TableName:="AnalysisPivot")
End With
End With
With PTable
.PivotFields("LOO").Orientation = xlRowField
.PivotFields("LOO").Position = 1

.PivotFields("Location").Orientation = xlRowField
.PivotFields("Location").Position = 2
.PivotFields("FY").Orientation = xlColumnField
.PivotFields("FY").Position = 1
.PivotFields("Month").Orientation = xlColumnField
.PivotFields("Month").Position = 2
.PivotFields("Month").Orientation = xlDataField
'no field captions
.DisplayFieldCaptions = False
End With
End Sub