excel_pivot2.bas

Public Function MakeExcelPivot() As Boolean 
On Error GoTo Err_MakeExcelPivot

    Dim TheDate As Date 
    TheDate = Now() 
   
    Dim strFilePath As String 
    strFilePath = "D:\blah" & Month(TheDate) & "-" & Day(TheDate) & "-" & Year(TheDate) & ".xls" 
    
    If Len(Dir(strFilePath)) > 0 Then 
        SetAttr strFilePath, vbNormal 
        Kill strFilePath 
    End If 
    
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryMakeExcelPivot", strFilePath, True 
    
   '***************************** 
   ' START Format the Excel 
   '***************************** 
    Dim objXL As Excel.Application 
    Set objXL = New Excel.Application 
    objXL.Visible = True 
    
    'objXL.Workbooks.Add 
    objXL.Workbooks.Open strFilePath 
    
    'objXL.ActiveSheet.Name = "Sheet1" 
    
    objXL.ActiveSheet.Columns("A:D").Select 
    objXL.ActiveWorkbook.Sheets.Add 
    objXL.ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ 
        "qryMakeExcelPivot!R1C1:R2192C3", Version:=xlPivotTableVersion10).CreatePivotTable _ 
        TableDestination:="Sheet1!R3C1", tableName:="PivotTable1", DefaultVersion _ 
        :=xlPivotTableVersion10 
    objXL.ActiveWorkbook.Sheets("Sheet1").Select 
    objXL.ActiveSheet.Cells(3, 1).Select 
    With objXL.ActiveSheet.PivotTables("PivotTable1").PivotFields("Type") 
        .Orientation = xlRowField 
        .Position = 1 
    End With 
    With objXL.ActiveSheet.PivotTables("PivotTable1").PivotFields("PERIOD") 
        .Orientation = xlRowField 
        .Position = 2 
    End With 
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("FieldToSumHere") 
        .Orientation = xlRowField 
        .Position = 3 
    End With 
    objXL.ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _ 
        "PivotTable1").PivotFields("FieldToSumHere"), "Sum of FieldToSumHere", _ 
        xlSum 
    With objXL.ActiveSheet.PivotTables("PivotTable1").PivotFields("PERIOD") 
        .Orientation = xlColumnField 
        .Position = 1 
    End With 
    
    'objXL.SaveWorkspace (strFilePath) 
    objXL.Workbooks.Close 
    objXL.Quit 
    
    MakeExcelPivot = True

Exit_MakeExcelPivot: 
    Exit Function 
    
Err_MakeExcelPivot: 
    MakeExcelPivot = False 
    MsgBox "Err_MakeExcelPivot (" & Err.Number & ") " & vbCrLf & Err.Description 
    Resume Exit_MakeExcelPivot

End Function