This demonstrates linking to Excel from Access And Updating a Pivot Table
Syntax Examples
Option Compare Database
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Dim strDirectoryLevel1 As String
Dim strDirectoryLevel2 As String
Dim strCurrentDir As String
Dim strUserName As String
Private Sub cmdCreateReport_Click()
' **************************************************************
' Establish Database Query Connection
' **************************************************************
Dim db As DAO.Database
Dim recIn As DAO.Recordset
' **************************************************************
' Establish Excel Communications from Access
' **************************************************************
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSelectedMovementData As Excel.Worksheet
Dim xlPivotTableWorksheet As Excel.Worksheet
Dim xlPivotTable As PivotTable
Dim xlPivotCache As PivotCache
Dim rngDataRange As Range
Dim strPivotName As String
Dim strNewRange As String
Dim rngStartPoint As Range
Dim rngNewRange As Range
Dim strNewRangeString As String
Dim lngLastRow As Long
Dim lngLastColumn As Long
Dim rngLastCell As Range
' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCount As Long
Dim strSavedFileName As String
' **************************************************************
' Validate Date Input
' **************************************************************
If Me.txtFromDate = "" Or IsNull(Me.txtFromDate) Then
MsgBox ("A From date is required")
Exit Sub
End If
If Year(Me.txtFromDate) < 2017 Then
MsgBox ("From Date Year Must Be 2017 or Greater")
Exit Sub
End If
If Me.txtToDate = "" Or IsNull(Me.txtToDate) Then
MsgBox ("A To date is required")
Exit Sub
End If
If Year(Me.txtToDate) < 2017 Then
MsgBox ("To Date Year Must Be 2017 or Greater")
Exit Sub
End If
If Me.txtFromDate >= Me.txtToDate Then
MsgBox ("From Date Must Be Less Than To Date")
Exit Sub
End If
If Me.frmReportSelection <> 1 Then
MsgBox ("This reports is waiting to be devloped")
Exit Sub
End If
' **************************************************************
' Save selected from and to dates to the global area
' **************************************************************
gblDateFrom = Me.txtFromDate
gblDateTo = Me.txtToDate
' **************************************************************
' Set up error handling
' **************************************************************
On Error GoTo Error_Handler:
' **************************************************************
' Verify That The Movement Template Exists
' **************************************************************
If Not FileExists("C:\BeerMovementTemplate\BeerMovementsReportTemplateV1.xlsx") Then
MsgBox ("Template C:\BeerMovementTemplate\BeerMovementsReportTemplateV1.xlsx Does Not Exist")
Exit Sub
End If
DoCmd.Hourglass True
' **************************************************************
' Open the Excel Beer Movement Ticket Template
' **************************************************************
Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Open("C:\BeerMovementTemplate\BeerMovementsReportTemplateV1.xlsx")
Set xlSelectedMovementData = xlWB.Sheets("BeerMovementData")
Set xlPivotTableWorksheet = xlWB.Sheets("Data Pivot")
Set xlPivotTable = xlPivotTableWorksheet.PivotTables("MovementsPivot")
Set xlPivotCache = xlPivotTable.PivotCache
' **************************************************************
' Populate the Template With Beer Movement Data
' **************************************************************
' ***********************************************************************
' Open the Movement Query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryForDateRangeBeerMovementPivot")
' ***********************************************************************
' Clear Existing Data in Template
' ***********************************************************************
xlSelectedMovementData.Rows("2:100").EntireRow.Delete
lngRowCount = 1
xlPivotTableWorksheet.Range("C1").Value = gblDateFrom & " Thru " & gblDateTo
' ***********************************************************************
' Loop Through Each Record And Populate The Excel Form
' ***********************************************************************
Do
' ***************************************************************
' Insert the beer movements into the BeerMovementsData worksheet
' ***************************************************************
lngRowCount = lngRowCount + 1
xlSelectedMovementData.Cells(lngRowCount, "A") = recIn!OakshireSerialNumber
xlSelectedMovementData.Cells(lngRowCount, "B") = recIn!MovementDate
xlSelectedMovementData.Cells(lngRowCount, "C") = recIn!ItemID
xlSelectedMovementData.Cells(lngRowCount, "D") = recIn!ItemDescription
xlSelectedMovementData.Cells(lngRowCount, "E") = recIn!SalesQty
xlSelectedMovementData.Cells(lngRowCount, "F") = recIn!PackageDescription
xlSelectedMovementData.Cells(lngRowCount, "G") = recIn!PackageType
xlSelectedMovementData.Cells(lngRowCount, "H") = recIn!TotalBBLS
xlSelectedMovementData.Cells(lngRowCount, "I") = recIn!Keg_Case
xlSelectedMovementData.Cells(lngRowCount, "J") = recIn!BBLSInKegs
xlSelectedMovementData.Cells(lngRowCount, "K") = recIn!BBLSInCases
xlSelectedMovementData.Cells(lngRowCount, "L") = recIn!SiteFrom
xlSelectedMovementData.Cells(lngRowCount, "M") = recIn!SiteTo
xlSelectedMovementData.Cells(lngRowCount, "N") = recIn!Carrier
xlSelectedMovementData.Cells(lngRowCount, "O") = recIn!Brand
recIn.MoveNext
Loop Until recIn.EOF
recIn.Close
Set recIn = Nothing
Set db = Nothing
' xlApp.Visible = True (Keep it invisible)
' ********************************************************
' Look up the updated last row and column after
' Access updated the data. Convert To a Range
' ********************************************************
lngLastRow = xlSelectedMovementData.Cells(xlSelectedMovementData.Rows.Count, "A").End(xlUp).Row
lngLastColumn = xlSelectedMovementData.Cells(1, xlSelectedMovementData.Columns.Count).End(xlToLeft).Column
Set rngLastCell = xlSelectedMovementData.Cells(lngLastRow, lngLastColumn)
Set rngStartPoint = xlSelectedMovementData.Range("A1")
Set rngNewRange = xlSelectedMovementData.Range(rngStartPoint, rngLastCell)
' ********************************************************
' Set up the new range string used by ChangePivotCache
' ********************************************************
strNewRangeString = xlWB.Path & "\" & "[" & xlWB.Name & "]" & "BeerMovementData!" & rngNewRange.Address(ReferenceStyle:=xlR1C1)
' ********************************************************
' Ask Excel to change the pivot table's data source
' ********************************************************
xlPivotTableWorksheet.PivotTables("MovementsPivot").ChangePivotCache xlWB. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:=(strNewRangeString), Version:=xlPivotTableVersion15)
' ********************************************************
' Tidy up with refreshes of the pivot table
' ********************************************************
xlPivotTableWorksheet.PivotTables("MovementsPivot").RefreshTable
xlPivotTableWorksheet.PivotTables("MovementsPivot").PivotCache.Refresh
xlPivotTableWorksheet.PivotTables("MovementsPivot").Update
' ***********************************************************************
' Print The Worksheet PO
' ***********************************************************************
xlPivotTableWorksheet.PrintOut
' **************************************************************
' Set Up Save Directory To Save The File
' This will only create a directory if one doesn't exist
' **************************************************************
Call CreateRegulatoryReportsDirectories
strSavedFileName = strDirectoryLevel2 & "Movement Summary" & "-" & Year(Me.txtFromDate) & "-" & Format(Month(Me.txtFromDate), "00") & "-" & Format(Day(Me.txtFromDate), "00") _
& " Thru " & Year(Me.txtToDate) & "-" & Format(Month(Me.txtToDate), "00") & "-" & Format(Day(Me.txtToDate), "00")
' **************************************************************
' Save it to the network drive
' **************************************************************
xlPivotTableWorksheet.PivotTables("MovementsPivot").SaveData = True
xlWB.SaveAs FileName:=strSavedFileName, FileFormat:=xlOpenXMLWorkbook
' **************************************************************
' If User Decides to also save a PDF, put code here
' **************************************************************
' **************************************************************
' Close the file
' **************************************************************
xlApp.DisplayAlerts = False
xlWB.Close SaveChanges:=False
xlApp.DisplayAlerts = True
'xlApp.Quit
'Set xlApp = Nothing
' **************************************************************
' Close the remaining objects
' **************************************************************
Error_Handler_Exit:
On Error Resume Next
If Not xlWB Is Nothing Then
xlApp.DisplayAlerts = False
xlWB.Close SaveChanges:=False
xlApp.DisplayAlerts = True
Set xlWB = Nothing
End If
If Not xlApp Is Nothing Then
xlApp.Quit
Set xlApp = Nothing
End If
If Not recIn Is Nothing Then
recIn.Close
Set recIn = Nothing
End If
If Not db Is Nothing Then Set db = Nothing
DoCmd.Hourglass False
Exit Sub
Error_Handler:
MsgBox "An Error Occurred In This Application" & vbCrLf & _
"Please Contact The Developer" & vbCrLf & vbCrLf & _
"Error Number = " & Err.Number & " Error Description = " & _
Err.Description, vbCritical
Resume Error_Handler_Exit
End Sub
Public Function CreateRegulatoryReportsDirectories()
strDirectoryLevel1 = "O:\Regulatory Reports " & Year(gblDateFrom)
strDirectoryLevel2 = strDirectoryLevel1 & "\" & Format(Month(gblDateFrom), "00") & " - " & MonthName(Month(gblDateFrom)) & "\"
strUserName = UserNameWindows()
If Not FolderExists(strDirectoryLevel1) Then
MkDir (strDirectoryLevel1)
End If
If Not FolderExists(strDirectoryLevel2) Then
MkDir (strDirectoryLevel2)
End If
End Function
Public Function FolderExists(FolderPath As String) As Boolean
' *******************************************************************************************
' * THIS FUNCTION WILL TEST IF A FOLDER EXISTS *
' *******************************************************************************************
On Error GoTo err_In_Locate
' ***********************************************************
' * See If A Folder Exists *
' ***********************************************************
FolderExists = (Len(Dir(FolderPath, vbDirectory)) > 0)
mod_ExitFunction:
Exit Function
' ***************************************************
' * Error Correction Routines *
' ***************************************************
err_In_Locate:
FolderExists = False
Resume mod_ExitFunction
End Function
Public Function FileExists(FilePath As String) As Boolean
' *******************************************************************************************
' * THIS FUNCTION WILL TEST IF A FILE EXISTS - Doesn't Work on a networked Drive *
' *******************************************************************************************
On Error GoTo err_In_Locate
' ***********************************************************
' * See If A File Exists - Provide The Full Path to the File
' ***********************************************************
FileExists = (Len(Dir(FilePath)) > 0)
mod_ExitFunction:
Exit Function
' ***************************************************
' * Error Correction Routines *
' ***************************************************
err_In_Locate:
FileExists = False
Resume mod_ExitFunction
End Function
Public Function DeleteFile(SourceFile As String) As Boolean
' *******************************************************************************************
' * DELETE A FILE *
' *******************************************************************************************
' *******************************************************************
' * (1) This function will delete a file *
' * (2) A full path to the file being deleted is recommended *
' * (3) If you omit the path, Access looks in the CurDir for the *
' * file to be deleted *
' *******************************************************************
On Error GoTo err_In_Delete
Kill SourceFile
DeleteFile = True
mod_ExitFunction:
Exit Function
' ***************************************************
' * File To Be Deleted Does Not Exist *
' ***************************************************
err_In_Delete:
DeleteFile = False
Resume mod_ExitFunction
End Function
Function UserNameWindows() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255
strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
If CBool(GetUserName(strBuffer, lngLen)) Then
UserNameWindows = Left$(strBuffer, lngLen - 1)
Else
UserNameWindows = ""
End If
End Function
