Links To Excel Code Examples

Tracing VBA Statements
Range/Wkb/Wks Variables
Add Grand Totals Using Ranges
Using Range Offset Property
Using Range Find Method
ConvertCellAddressToRange
Set Conditional Formatting
Union Of Ranges
Parse Range Strings
Delete Duplicate Rows
Delete Rows And Columns
Worksheet Variables
TypeName And TypeOf
Loop Through Worksheets
Loop Through Open Workbooks
Form Button Magic
Command Button Magic
Add Worksheets Dynamically
ImportExternalWorksheets
Find Last Row Or Column
Copy And Paste Special
Copy To Specific Cell Types
Range Copy With Filter
ExcelFileOpenSaveClose
ExcelFileOpenSaveCSV
Open An Excel File
Open An Excel File w/Params
Open An Excel File On Web
Save A Workbook
Save A Workbook Using mso
Clone A Workbook
Test If WEB URL Exists
Parse Using Split Command
Using Classes in Excel
TypeStatementStructures
Color Management
Convert Cell Color To RGB
Sort Methods 2003 - 2010
Sort Alpha/Numeric In ASCII
Search Using Match Function
Search Using Vlookup Function
Search Using Xlookup Function
Using Find Instead of Vlookup
Remove String Non-Printables
Auto_Open And Auto_Close
Initialize Form At Open
Edit Numerics In UserForm
Load Combo And List Boxes
Floating Sheet Combo Boxes
Advanced User Form Coding
Excel Events
Worksheet Change Events
Binary Search Of Array
Typecast Constants
Excel Error Handling
Handling Optional Parameters
Data Validation Drop Downs
Insert Data Validation Sub
Read A Text File w/Handle
Write A Text File w/Handle
Read a Binary File w/Handle
Update a Binary File w/Handle
Binary File Copy and Update
Read A Text Fiile w/Script
Text File Processing Examples
Test For Exists Or Open
Splash Screen
Dynamically Load Formulas
PaymentStreamsByDate
Date Examples
Date Find Same Days
Convert Month To Number
Initialize Arrays
Load Arrays Using Evaluate
ChartsAndGraphsVBA
Redim An Array
Reassign Button Action
Timer Functions
Legacy Calendar Control
Excel 2010 Date Picker
Date Picker Alternative
Generate Multiple Worksheets
Read Access Data Into Excel
Send Outlook Email w/Attach
Copy AutoFilters To Sheets
Export A Text File
Get Windows User Name
VBA Format Statement
Manipulate Files via VBA
Dynamically Load Images
Loop Through Worksheet Objects
Loop Through Form Objects
Loop Through Files with DIR
Active-X Checkboxes
Add Forms Checkboxes Dynam
Paste Pictures Into Excel
Copy Pictures Sheet To Sheet
Copy Pictures Sheet To Sheet
Create Forms Buttons With VBA
Extract Filename From Path
Convert R1C1 Format to A1
Special Cells Property
Insert Cell Comments

Links To Access Code Examples

DAO Versus ADODB
SearchVBACodeStrings
Interface Excel With Access
Create Form Manually
Create Recordset With AddNew
Multi-Select List Boxes
Update Field(s) In A Recordset
Update Excel Pivot From Access
Import A Tab Delimited File
Export Excel FileDialog
Create Excel Within Access
Open Excel Within Access
Open Excel OBJ From Access
Format Excel From Access
Control Excel via Access VBA
On Error Best Practices
Import Tab Delim w/WinAPI
Initialize Global Variables
Using TempVars For Globals
Access Error Handling
Loop Through Form Controls
Insert A Calendar Control
Create A Filtered Recordset
Populate Combo Boxes
Bookmarks And Forms
Combo Box Multiple Sources
Passing Form Objects
Create VBA SQL Statements
Create Dynamic Queries
Display File Images On A Form
Manipulate Files via VBA
Manipulate Files via Scripting
Number Subform Records
Reference Subform Objects
Parse Delimited Fields
Parameterized Queries (VBA)
Manipulating QueryDefs In VBA
FindFirst On Combined Keys
Dlookup Command
Dlookup In Form Datasheet
Execute SQL Delete Records
Commit Form To Table
Report With No Data
Reference Form Objects
DSNLess Connections To MySQL
Print Active Form Record
Count Records in Linked Tables
Delete Empty Tables
Open Linked SQL Tables

 

Format An Excel Template from Access Using VBA Full Code Example

Suppose you have a nicely formatted Excel worksheet, and you want to populate it from an Access Database. Access has the VBA tools to allow it to open, populate, format and print an external workbook/worksheet. Access's report writing capability is very flexible, but for really specialty reports, populating an external Excel worksheet provides many additional options for professional looking reports.

The code shown below illustrates using multiple examples. The routine shown below is activated when a user clicks a custom print button on the main form. Make sure to include the Microsoft Excel Object Library which is located in the Visual Basic Environment (Alt-F11) under Tools, References.

Program Code

Option Compare Database
Option Base 1
Option Explicit
Dim strSavePath           As String
Dim strPathToTemplates    As String
Dim strTemplateToUse      As String
Dim strUserName           As String
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub cmdAdjustPOCommentSequence_Click()
DoCmd.OpenForm "frmPOCommentsForUpdate", acFormDS
' DoCmd.RunCommand (acCmdDatasheetView)
End Sub

Private Sub cmdCreateProjectedToBuyReport_Click()
On Error GoTo Error_Handler
' **************************************************************
' 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 xlReport              As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter          As Long
Dim strSaveAsName          As String

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "ProjectedToBuyTemplateV3.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Projected To Buy Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

DoCmd.Hourglass True
' **************************************************************
' Create the Projected To Buy Table With Today's Data
' **************************************************************
Call CreateProjectedToBuyTableData

' **************************************************************
' Purge PTB Quarterly Calcs Table
' **************************************************************
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryPTB_Purge_tblPTB_CalcsForQuarterlyTrends"
DoCmd.OpenQuery "qryPTB_AppendPTBCalcsWithQuarterlyTrends"
DoCmd.OpenQuery "qry_PTB_UpdatePTBWithQuarterlyTrends"
DoCmd.SetWarnings True

' ***********************************************************************
' Open the Projected To Buy Data
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryListProjectedToBuyTable", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' **************************************************************
' Open the Sales Compare Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("ProjectedToBuy")
' xlApp.Visible = True

' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Projected To Buy As Of " & Date

' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 3

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with the Projected To Buy Balances
    ' ***************************************************************
    xlReport.Cells(lngRowCounter, "A") = recIn!Item
    xlReport.Cells(lngRowCounter, "B") = recIn!Description
    xlReport.Cells(lngRowCounter, "C") = recIn!PhysicalOnHandBottles
    xlReport.Cells(lngRowCounter, "D") = recIn!RawGoodsBottles
    xlReport.Cells(lngRowCounter, "E") = recIn!PORawGoodsBottles
    xlReport.Cells(lngRowCounter, "F") = recIn!POExpectedArrivalDate
    xlReport.Cells(lngRowCounter, "G") = recIn!Physical_RG_PO_TotalBottles
    xlReport.Cells(lngRowCounter, "H") = recIn!MonthlyTRBottles
    xlReport.Cells(lngRowCounter, "I") = recIn!ProjectedMonthsInStock
    xlReport.Cells(lngRowCounter, "J") = recIn!MonthsLeadTime
    xlReport.Cells(lngRowCounter, "K") = recIn!NetAllowance
    xlReport.Cells(lngRowCounter, "L") = recIn!MOQ
    xlReport.Cells(lngRowCounter, "M") = recIn!Qtr1PctVariance
    xlReport.Cells(lngRowCounter, "N") = recIn!Qtr2PctVariance
    xlReport.Cells(lngRowCounter, "O") = recIn!Qtr3PctVariance
    xlReport.Cells(lngRowCounter, "P") = recIn!Qtr4PctVariance
    xlReport.Cells(lngRowCounter, "Q") = recIn!Last6MonthsPctVariance
    recIn.MoveNext
Loop Until recIn.EOF

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "ProjectedToBuy_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlReport Is Nothing Then Set xlReport = Nothing
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
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

Private Sub cmdCreateSalesRepLoadAnalysis_Click()
On Error GoTo Error_Handler
' **************************************************************
' 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 xlReport              As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter          As Long
Dim strSaveAsName          As String
Dim strMonthName(1 To 12)  As String

strMonthName(1) = "January"
strMonthName(2) = "February"
strMonthName(3) = "March"
strMonthName(4) = "April"
strMonthName(5) = "May"
strMonthName(6) = "June"
strMonthName(7) = "July"
strMonthName(8) = "August"
strMonthName(9) = "September"
strMonthName(10) = "October"
strMonthName(11) = "November"
strMonthName(12) = "December"

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "LoadAnalysisTemplate.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Projected To Buy Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

DoCmd.Hourglass True

' ***********************************************************************
' Open the sales rep analysis query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qrySalesByRepLastMonthSummary", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' **************************************************************
' Open the Sales Compare Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("SalesSummary")
' xlApp.Visible = True

' ***************************************************************
' Unlock the worksheet
' ***************************************************************
xlReport.Unprotect

' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A2") = "Sales Load Analysis As Of " & strMonthName(recIn!SalesMonth) & " " & Year(Date)
xlReport.Range("A12") = "Sales Load Analysis As Of " & strMonthName(recIn!SalesMonth) & " " & Year(Date)

' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 3

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with the Projected To Buy Balances
    ' ***************************************************************
    xlReport.Cells(lngRowCounter, "A") = recIn!RepName
    xlReport.Cells(lngRowCounter, "B") = recIn!MonthlySales
    xlReport.Cells(lngRowCounter, "C") = recIn!NumberOfOrders
    xlReport.Cells(lngRowCounter, "D") = recIn!HoursWorked
    recIn.MoveNext
Loop Until recIn.EOF

' ***************************************************************
' Lock the worksheet
' ***************************************************************
xlReport.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "SalesRepLoadAnalysis_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlReport Is Nothing Then Set xlReport = Nothing
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
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

Private Sub cmdEditExpectedToShip_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryPO_AppendNewPOEstimatedShipDates"
DoCmd.OpenQuery "qryPO_UpdateDeleteFlagExpectedShipDates"
DoCmd.OpenQuery "qryPO_DeleteClosedPOForExpectedShipDates"
DoCmd.OpenForm "frmPO_UpdateEstimatedShipDates", acFormDS
DoCmd.SetWarnings True
End Sub

Private Sub cmdEditMOQForBOM_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryBOM_OtherComponents", acViewNormal, acEdit
DoCmd.SetWarnings True
End Sub

Private Sub cmdEditMPSProductStatus_Click()
DoCmd.OpenForm "frmMPS_StatusUpdate", acFormDS
End Sub

Private Sub cmdSalesByRepLast35Days_Click()
On Error GoTo Error_Handler
' **************************************************************
' 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 xlRollup              As Excel.Worksheet
Dim xlDetail              As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter          As Long
Dim strSaveAsName          As String

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "SalesByRepLast35DaysTemplate.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Sales Rep Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

DoCmd.Hourglass True

' ***********************************************************************
' Open the Rollup Query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qrySalesByRepLast35DaysRollup", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' **************************************************************
' Open the Sales By Rep Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlRollup = xlWB.Sheets("SalesRollup")
Set xlDetail = xlWB.Sheets("SalesByRepLast35")
' xlApp.Visible = True

' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlRollup.Range("A1") = "Sales Rollup Last 35 Days As Of " & Date
xlDetail.Range("A1") = "Sales Detail Last 35 Days As Of " & Date

' ***************************************************************
' Loop through all the Rollup Records and insert them into
' the template
' ***************************************************************
lngRowCounter = 2

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with the Projected To Buy Balances
    ' ***************************************************************
    xlRollup.Cells(lngRowCounter, "A") = recIn!SalesRep
    xlRollup.Cells(lngRowCounter, "B") = recIn!Name
    xlRollup.Cells(lngRowCounter, "C") = recIn!SalesLast35Days
    recIn.MoveNext
Loop Until recIn.EOF

recIn.Close
Set recIn = Nothing

Set recIn = db.OpenRecordset("qrySalesByRepLast35Days", dbOpenSnapshot)

' ***************************************************************
' Loop through all the detail records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 2

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with the Projected To Buy Balances
    ' ***************************************************************
    xlDetail.Cells(lngRowCounter, "A") = recIn!SalesRep
    xlDetail.Cells(lngRowCounter, "B") = recIn!Cust
    xlDetail.Cells(lngRowCounter, "C") = recIn!Name
    xlDetail.Cells(lngRowCounter, "D") = recIn!OrderDate
    xlDetail.Cells(lngRowCounter, "E") = recIn!SaleAmt
    recIn.MoveNext
Loop Until recIn.EOF

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "SalesByRepLast35Days_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlRollup Is Nothing Then Set xlRollup = Nothing
If Not xlDetail Is Nothing Then Set xlDetail = Nothing
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
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

Private Sub cmdCreateMonthlyProductionSchedule_Click()
On Error GoTo Error_Handler
' **************************************************************
' 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 xlReport              As Excel.Worksheet
Dim xlOtherComponents     As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter          As Long
Dim strSaveAsName          As String
Dim strAppendQuery         As String
Dim strCreateTableQuery    As String

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "MonthlyProductionScheduleV2.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Monthly Production Schedule Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

' ***********************************************************************
' Open the Monthly Production Schedule Query
' ***********************************************************************
Set db = CurrentDb()

' **************************************************************
' Update the MPS Conversion Table
' **************************************************************
DoCmd.SetWarnings False
strAppendQuery = "qryMPS_LastYearMthlyAvgSales"
strCreateTableQuery = "qryMPS_MonthlyProductionScheduleTable"

DoCmd.DeleteObject acTable, "tblMPS_AverageMthlySalesByItem"
DoCmd.DeleteObject acTable, "tblMPS_MonthlyProductionSchedule"

db.Execute strAppendQuery, dbFailOnError
db.Execute strCreateTableQuery, dbFailOnError
DoCmd.SetWarnings True

Set recIn = db.OpenRecordset("qryMPS_MonthlyProductionSchedule", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

DoCmd.Hourglass True

' **************************************************************
' Open the Monthly Production Schedule Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("MonthlyProductionSchedule")
Set xlOtherComponents = xlWB.Sheets("OtherBOMComponents")

' xlApp.Visible = True

' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Monthly Production Schedule As Of " & Date
xlOtherComponents.Range("A1") = "Other BOM Components As Of " & Date

' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 4

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with Scheduling Data
    ' ***************************************************************
    xlReport.Cells(lngRowCounter, "A") = recIn!Item
    xlReport.Cells(lngRowCounter, "B") = recIn!Description
    xlReport.Cells(lngRowCounter, "C") = recIn!MonthlyTRBottles
    xlReport.Cells(lngRowCounter, "D") = recIn!QtyOnHand
    xlReport.Cells(lngRowCounter, "E") = recIn!SupplyInMonths
    xlReport.Cells(lngRowCounter, "F") = recIn!RGQtyOnHand
    xlReport.Cells(lngRowCounter, "G") = recIn!AmountToRun
    xlReport.Cells(lngRowCounter, "H") = recIn!RawGoodsRequired
    xlReport.Cells(lngRowCounter, "I") = recIn!NeedBy
    xlReport.Cells(lngRowCounter, "J") = recIn!ProductionTime
    xlReport.Cells(lngRowCounter, "K") = recIn!Status
    
    ' ***************************************************************
    ' Highlight Critical Dates in Red Or Yellow
    ' ***************************************************************
    If IsNull(recIn!NeedBy) Or recIn!NeedBy = "" Then
        GoTo GetNextRecord
    End If
    
    If recIn!NeedBy - Date <= 7 Then
        xlReport.Cells(lngRowCounter, "I").Interior.Color = 16738047
    ElseIf recIn!NeedBy - Date < 21 Then
        xlReport.Cells(lngRowCounter, "I").Interior.Color = 65535
    End If

GetNextRecord:
    recIn.MoveNext
Loop Until recIn.EOF

' ********************************************************
' Populate the 2nd worksheet containing non-raw goods
' ********************************************************
recIn.Close
Set recIn = Nothing

Set recIn = db.OpenRecordset("qryMPS_NonRawGoodsVariance", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 3

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with Non-Raw Goods Variances
    ' ***************************************************************
    xlOtherComponents.Cells(lngRowCounter, "A") = recIn!ComponentItem
    xlOtherComponents.Cells(lngRowCounter, "B") = recIn!Description
    xlOtherComponents.Cells(lngRowCounter, "C") = recIn!QtyOnHand
    xlOtherComponents.Cells(lngRowCounter, "D") = recIn!TotalRequired
    xlOtherComponents.Cells(lngRowCounter, "E") = recIn!Variance
    xlOtherComponents.Cells(lngRowCounter, "F") = recIn!MinimumOH
    xlOtherComponents.Cells(lngRowCounter, "G") = recIn!MaximumOH
    xlOtherComponents.Cells(lngRowCounter, "H") = recIn!MOQ
    xlOtherComponents.Cells(lngRowCounter, "I") = recIn!LeadTime
    recIn.MoveNext
Loop Until recIn.EOF

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "MonthlyProductionSchedule_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlReport Is Nothing Then Set xlReport = Nothing
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
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

Private Sub cmdEditBottleConversionFactors_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryPTB_BottleConversionFactors", acViewNormal, acEdit
DoCmd.SetWarnings True
End Sub

Private Sub cmdEditRawGoodsConversionFactors_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryPTB_RawGoodsConversionFactors", acViewNormal, acEdit
DoCmd.SetWarnings True
End Sub

Private Sub cmdEditMPSConversionFactors_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryMPS_BottleConversionFactors", acViewNormal, acEdit
DoCmd.SetWarnings True
End Sub

Private Sub cmdEditMPSFinders_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryMPS_Finders", acViewNormal, acEdit
DoCmd.SetWarnings True
End Sub

Private Sub cmdEnterProjectedToBuyItems_Click()
DoCmd.OpenForm "frmUpdateFinders", acFormDS
End Sub

Private Sub cmdOpenPurchaseOrders_Click()
On Error GoTo Error_Handler
' **************************************************************
' Establish Database Query Connection
' **************************************************************
Dim db                    As DAO.Database
Dim recIn                 As DAO.Recordset
Dim recInComments         As DAO.Recordset

' **************************************************************
' Establish Excel Communications from Access
' **************************************************************
Dim xlApp                 As Excel.Application
Dim xlWB                  As Excel.Workbook
Dim xlReport              As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter           As Long
Dim strSaveAsName           As String
Dim strLastVendorNumber     As String
Dim strLastPONumber         As String
Dim dblLastTotalPOAmount    As Double
Dim dblTotalVendorPurchases As Double
Dim dblTotalAllPOs          As Double
Dim strRange                As String
Dim strSQL                  As String
Dim strRangeComments        As String
Dim strSingleComment        As String
Dim strJoinedComments       As String

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
DoCmd.Hourglass True
strUserName = UserNameWindows()
strTemplateToUse = "OpenPurchaseOrdersTemplateV3.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Open PO Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

' ***********************************************************************
' Update The PO Comments
' ***********************************************************************
Call AppendPOComments

' ***********************************************************************
' Initialize the PO Item Totals Table Used To Calculate Needed By Date
' ***********************************************************************
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryPOItemTotalsDelete", acViewNormal, acEdit
DoCmd.OpenQuery "qryPOItemTotalsCreatePart2", acViewNormal, acEdit
DoCmd.SetWarnings True

' ***********************************************************************
' Open the Open Purchase Orders Query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryOpenPurchaseOrders", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' ***********************************************************************
' Initialize Control Fields
' ***********************************************************************
strLastVendorNumber = recIn!VendorNumber
strLastPONumber = recIn!PONumber
dblLastTotalPOAmount = recIn!TotalPOAmount
dblTotalVendorPurchases = recIn!TotalPOAmount
dblTotalAllPOs = 0

' **************************************************************
' Open the Purchase Orders Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("OpenPurchaseOrders")
' xlApp.Visible = True

' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Open Purchase Orders As Of " & Date

' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 2

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' If the Vendor changed, then publish PO and Vendor Totals
    ' ***************************************************************
    If recIn!VendorNumber <> strLastVendorNumber Then
        ' ***************************************************************
        ' Start Of Comments Section on a Vendor Change
        ' ***************************************************************
        ' ***************************************************************
        ' Set up the query to see if there are any comments
        ' For The Last PO
        ' ***************************************************************
        strSQL = _
        "SELECT tblPOComments.PONumber, tblPOComments.Comment, tblPOComments.TrueSequence FROM tblPOComments " & _
        "WHERE tblPOComments.PONumber=" & """" & strLastPONumber & """" & _
        " ORDER BY tblPOComments.TrueSequence" & ";"

        ' ***************************************************************
        ' Open the comments record set for a single PO
        ' ***************************************************************
        Set recInComments = db.OpenRecordset(strSQL)

        If Not recInComments.EOF Then
            strJoinedComments = ""
        ' ***************************************************************
        ' Loop Through Comments
        ' ***************************************************************
            Do
                strSingleComment = Trim(recInComments!Comment)
                If strJoinedComments = "" Then
                    strJoinedComments = strSingleComment
                ElseIf Len(strJoinedComments) + Len(strSingleComment) < 200 Then
                    strJoinedComments = strJoinedComments & "; " & strSingleComment
                Else
                   strRangeComments = "A" & lngRowCounter & ":" & "N" & lngRowCounter
                   With xlReport.Range(strRangeComments)
                       .MergeCells = True
                       .HorizontalAlignment = xlLeft
                       .Font.Color = -16776961
                       .Font.TintAndShade = 0
                       .Font.Bold = True
                   End With
                   xlReport.Cells(lngRowCounter, "A") = strJoinedComments
                   strJoinedComments = strSingleComment
                   lngRowCounter = lngRowCounter + 1
                End If
            recInComments.MoveNext
            Loop Until recInComments.EOF
            recInComments.Close
            Set recInComments = Nothing
        ' ***************************************************************
        ' End Loop Through Comments
        ' ***************************************************************
        ' ***************************************************************
        ' Process Any Remaining Comments in strJoinedComments
        ' ***************************************************************
       If strJoinedComments <> "" Then
         strRangeComments = "A" & lngRowCounter & ":" & "N" & lngRowCounter
         With xlReport.Range(strRangeComments)
           .MergeCells = True
           .HorizontalAlignment = xlLeft
           .Font.Color = -16776961
           .Font.TintAndShade = 0
           .Font.Bold = True
         End With
         xlReport.Cells(lngRowCounter, "A") = strJoinedComments
         lngRowCounter = lngRowCounter + 1
           End If
        ' ***************************************************************
        ' No Comments for this PO
        ' ***************************************************************
        Else
            recInComments.Close
            Set recInComments = Nothing
        End If

        ' ***************************************************************
        ' End Of Comments for this PO
        ' ***************************************************************
        xlReport.Cells(lngRowCounter, "H") = "*** Total PO Amount ***"
        xlReport.Cells(lngRowCounter, "K") = dblLastTotalPOAmount
        lngRowCounter = lngRowCounter + 1
        xlReport.Cells(lngRowCounter, "H") = "*** Total All Vendor PO's ***"
        xlReport.Cells(lngRowCounter, "K") = dblTotalVendorPurchases
        ' Highlight The Total For Each Vendor
        strRange = "A" & lngRowCounter & ":" & "N" & lngRowCounter
        With xlReport.Range(strRange).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorLight2
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
        dblTotalAllPOs = dblTotalAllPOs + dblTotalVendorPurchases
        strLastVendorNumber = recIn!VendorNumber
        strLastPONumber = recIn!PONumber
        dblLastTotalPOAmount = recIn!TotalPOAmount
        dblTotalVendorPurchases = recIn!TotalPOAmount
        lngRowCounter = lngRowCounter + 2
    End If
    
    ' ***************************************************************
    ' If the PO changed, then publish the PO Total
    ' ***************************************************************
    If recIn!PONumber <> strLastPONumber Then
        ' ***************************************************************
        ' Start Of Comments Section on a PO Change
        ' ***************************************************************
        ' ***************************************************************
        ' Set up the query to see if there are any comments
        ' For The Last PO
        ' ***************************************************************
        strSQL = _
        "SELECT tblPOComments.PONumber, tblPOComments.Comment, tblPOComments.TrueSequence FROM tblPOComments " & _
        "WHERE tblPOComments.PONumber=" & """" & strLastPONumber & """" & _
        " ORDER BY tblPOComments.TrueSequence" & ";"

        ' ***************************************************************
        ' Open the comments record set for a single PO
        ' ***************************************************************
        Set recInComments = db.OpenRecordset(strSQL)

        If Not recInComments.EOF Then
            strJoinedComments = ""
        ' ***************************************************************
        ' Loop Through Comments
        ' ***************************************************************
            Do
                strSingleComment = Trim(recInComments!Comment)
                If strJoinedComments = "" Then
                    strJoinedComments = strSingleComment
                ElseIf Len(strJoinedComments) + Len(strSingleComment) < 200 Then
                    strJoinedComments = strJoinedComments & "; " & strSingleComment
                Else
                   strRangeComments = "A" & lngRowCounter & ":" & "N" & lngRowCounter
                   With xlReport.Range(strRangeComments)
                       .MergeCells = True
                       .HorizontalAlignment = xlLeft
                       .Font.Color = -16776961
                       .Font.TintAndShade = 0
                       .Font.Bold = True
                   End With
                   xlReport.Cells(lngRowCounter, "A") = strJoinedComments
                   strJoinedComments = strSingleComment
                   lngRowCounter = lngRowCounter + 1
                End If
            recInComments.MoveNext
            Loop Until recInComments.EOF
            recInComments.Close
            Set recInComments = Nothing
        ' ***************************************************************
        ' End Loop Through Comments
        ' ***************************************************************
        ' ***************************************************************
        ' Process Any Remaining Comments in strJoinedComments
        ' ***************************************************************
       If strJoinedComments <> "" Then
         strRangeComments = "A" & lngRowCounter & ":" & "N" & lngRowCounter
         With xlReport.Range(strRangeComments)
           .MergeCells = True
           .HorizontalAlignment = xlLeft
           .Font.Color = -16776961
           .Font.TintAndShade = 0
           .Font.Bold = True
         End With
         xlReport.Cells(lngRowCounter, "A") = strJoinedComments
         lngRowCounter = lngRowCounter + 1
           End If
        ' ***************************************************************
        ' No Comments for this PO
        ' ***************************************************************
        Else
            recInComments.Close
            Set recInComments = Nothing
        End If
        
        ' ***************************************************************
        ' End Of Comments for this PO
        ' ***************************************************************
        xlReport.Cells(lngRowCounter, "H") = "*** Total PO Amount ***"
        xlReport.Cells(lngRowCounter, "K") = dblLastTotalPOAmount
        lngRowCounter = lngRowCounter + 2
        strLastPONumber = recIn!PONumber
        dblLastTotalPOAmount = recIn!TotalPOAmount
        dblTotalVendorPurchases = dblTotalVendorPurchases + recIn!TotalPOAmount
    End If
    
    ' ***************************************************************
    ' Populate the workbook with the Open Purchase Order Data
    ' ***************************************************************
    xlReport.Cells(lngRowCounter, "A") = recIn!VendorNumber
    xlReport.Cells(lngRowCounter, "B") = recIn!VendorName
    xlReport.Cells(lngRowCounter, "C") = recIn!PONumber
    xlReport.Cells(lngRowCounter, "D") = recIn!OrderDate
    xlReport.Cells(lngRowCounter, "E") = recIn!ExpectedRcptDate
    'xlReport.Cells(lngRowCounter, "F") = recIn!NeededByDate
    xlReport.Cells(lngRowCounter, "F") = NeedDate(recIn!Item, recIn!OnHandBottles, recIn!RawGoodsBottles1, recIn!PORawGoodsBottles, recIn!MonthlyTurnRate)
    xlReport.Cells(lngRowCounter, "G") = recIn!Item
    xlReport.Cells(lngRowCounter, "H") = recIn!ItemDescription
    xlReport.Cells(lngRowCounter, "I") = recIn!QtyRemaining
    xlReport.Cells(lngRowCounter, "J") = recIn!UnitPurchaseCost
    xlReport.Cells(lngRowCounter, "K") = recIn!LineItemCost
    xlReport.Cells(lngRowCounter, "L") = recIn!Terms
    xlReport.Cells(lngRowCounter, "M") = recIn!ShipVia
    xlReport.Cells(lngRowCounter, "N") = recIn!EstimatedShipDate
    If IsNull(recIn!NeededByDate) Or recIn!NeededByDate = "" Then
        GoTo GetNextRecord
    End If
    
    If recIn!ExpectedRcptDate >= xlReport.Cells(lngRowCounter, "F") Then
        xlReport.Cells(lngRowCounter, "F").Interior.Color = 16738047
    ElseIf xlReport.Cells(lngRowCounter, "F") - recIn!ExpectedRcptDate < 15 Then
        xlReport.Cells(lngRowCounter, "F").Interior.Color = 65535
    End If
    
GetNextRecord:
    recIn.MoveNext
Loop Until recIn.EOF

' ********************************************************
' Publish the totals for the last vendor/po
' ********************************************************
lngRowCounter = lngRowCounter + 1
xlReport.Cells(lngRowCounter, "H") = "*** Total PO Amount ***"
xlReport.Cells(lngRowCounter, "K") = dblLastTotalPOAmount
lngRowCounter = lngRowCounter + 1
xlReport.Cells(lngRowCounter, "H") = "*** Total All Vendor PO's ***"
xlReport.Cells(lngRowCounter, "K") = dblTotalVendorPurchases
strRange = "A" & lngRowCounter & ":" & "N" & lngRowCounter
With xlReport.Range(strRange).Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorLight2
    .TintAndShade = 0.799981688894314
    .PatternTintAndShade = 0
End With
lngRowCounter = lngRowCounter + 1
dblTotalAllPOs = dblTotalAllPOs + dblTotalVendorPurchases
xlReport.Cells(lngRowCounter, "H") = "*** Grand Total All PO's ***"
xlReport.Cells(lngRowCounter, "K") = dblTotalAllPOs

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "OpenPurchaseOrders_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlReport Is Nothing Then Set xlReport = Nothing

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 recInComments Is Nothing Then
    recInComments.Close
    Set recInComments = Nothing
End If

If Not db Is Nothing Then Set db = Nothing
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

Private Sub cmdTop3ProdsByCustomer_Click()
    On Error GoTo Error_Handler
    ' **************************************************************
    ' 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 xlHeader              As Excel.Worksheet
    Dim xlShSales             As Excel.Worksheet
    Dim xlShPivot             As Excel.Worksheet
    Dim xlPivotTable          As PivotTable
    Dim xlPivotCache          As PivotCache
    
    ' **************************************************************
    ' Other Variables
    ' **************************************************************
    Dim lngNumberOfRows       As Long
    Dim strRowsToInsert       As String
    Dim lngLastRowInTable     As Long
    Dim lngFillRow            As Long
    Dim strSaveAsName         As String

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "Top3ProductsByCustomerTemplate.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Sales 4 Year Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Create Sales History Table for 3 Years
' **************************************************************
DoCmd.Hourglass True
Call CreateDetailFor4Years

' ***********************************************************************
' Open the Top 3 Products Sold To Each Customer
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryList4YearsTopProducts", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' ***********************************************************************
' Count the rows that need to be inserted into the Template
' ***********************************************************************
recIn.MoveLast
lngNumberOfRows = recIn.RecordCount
recIn.MoveFirst

' **************************************************************
' Open the Sales Compare Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlHeader = xlWB.Sheets("MarcoPharmaHeader")
Set xlShSales = xlWB.Sheets("SalesHistoryDetail4Years")
Set xlShPivot = xlWB.Sheets("SalesPivot")
' xlApp.Visible = True

' **************************************************************
' Update the header date
' **************************************************************
xlHeader.Range("B19") = "As of " & Date

' **************************************************************
' Open up space in the Excel Workbook for inserting all the
' rows from the 4 year top seller table
' **************************************************************
strRowsToInsert = "3:" & lngNumberOfRows + 2
xlShSales.Rows(strRowsToInsert).Insert Shift:=xlDown

lngFillRow = 2

' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
Do
    lngFillRow = lngFillRow + 1
    If lngFillRow > lngNumberOfRows + 2 Then
        MsgBox ("Row Number " & lngFillRow & " Exceeds Space Allocation")
        GoTo Error_Handler_Exit
    End If
    ' ***************************************************************
    ' Poulate the workbook with sales dollars and returns
    ' ***************************************************************
    xlShSales.Cells(lngFillRow, "A") = recIn!Name
    xlShSales.Cells(lngFillRow, "B") = recIn!TransYear
    xlShSales.Cells(lngFillRow, "C") = recIn!SumOfSaleAmt
    xlShSales.Cells(lngFillRow, "D") = recIn!Description
    xlShSales.Cells(lngFillRow, "E") = recIn!Item
    xlShSales.Cells(lngFillRow, "F") = recIn!Customer
    recIn.MoveNext
Loop Until recIn.EOF

' ********************************************************
' Determine the last row of the updated table
' ********************************************************
lngLastRowInTable = xlShSales.Cells(xlShSales.Rows.Count, "A").End(xlUp).Row

' ********************************************************
' Delete the last and first setup rows
' ********************************************************
xlShSales.Rows(lngLastRowInTable).EntireRow.Delete Shift:=xlUp
xlShSales.Rows(2).EntireRow.Delete Shift:=xlUp
xlHeader.Activate
xlHeader.Range("A1").Select

' ********************************************************
' Update the Pivot Table
' ********************************************************
Set xlPivotTable = xlShPivot.PivotTables("4YearPivot")
Set xlPivotCache = xlPivotTable.PivotCache
xlPivotCache.Refresh

'xlShPivot.PivotTables("3YearPivot").PivotCache.Refresh

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "Top3ProductsByCustomer_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
    DoCmd.Hourglass False
    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 xlHeader Is Nothing Then Set xlHeader = Nothing
    If Not xlShSales Is Nothing Then Set xlShSales = Nothing
    If Not xlShPivot Is Nothing Then Set xlShPivot = Nothing
    If Not xlPivotTable Is Nothing Then Set xlPivotTable = Nothing
    If Not xlPivotCache Is Nothing Then Set xlPivotCache = Nothing
    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
    ' MsgBox ("Closing Access - Please Restart")
    ' Access.Quit
    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

Private Sub cmdTopAndBottomSellers_Click()

On Error GoTo Error_Handler
' **************************************************************
' 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 xlReport              As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter          As Long
Dim strSaveAsName          As String

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "TopAndBottom25ProductSales.xlsm"
'strTemplateToUse = "TopAndBottom25ProductSales.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Projected To Buy Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

DoCmd.Hourglass True

' ***********************************************************************
' Open the Top 25 Sellers
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qry30DaySalesTop25", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' **************************************************************
' Open the Sales Compare Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("HighAndLowProdSales")
' xlApp.Visible = True

' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Top and Bottom Sales For The Last 31 Days as of " & Date

' ***************************************************************
' Loop through all top sellers and push them into the template
' ***************************************************************
lngRowCounter = 4

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with the Projected To Buy Balances
    ' ***************************************************************
    xlReport.Cells(lngRowCounter, "A") = recIn!Item
    xlReport.Cells(lngRowCounter, "B") = recIn!Description
    xlReport.Cells(lngRowCounter, "C") = recIn!DollarsSold
    xlReport.Cells(lngRowCounter, "D") = recIn!UnitsSold
    recIn.MoveNext
Loop Until lngRowCounter = 29

recIn.Close
Set recIn = Nothing

' ********************************************************
' Now prepare for the lowest 25 sellers
' ********************************************************
Set recIn = db.OpenRecordset("qry30DaySalesBottom25", dbOpenSnapshot)

If recIn.RecordCount = 0 Then
    GoTo Error_Handler_Exit
End If

' ***************************************************************
' Loop through all bottom sellers and push them into the template
' ***************************************************************
lngRowCounter = 31

Do
    lngRowCounter = lngRowCounter + 1
    ' ***************************************************************
    ' Poulate the workbook with the Projected To Buy Balances
    ' ***************************************************************
    xlReport.Cells(lngRowCounter, "A") = recIn!Item
    xlReport.Cells(lngRowCounter, "B") = recIn!Description
    xlReport.Cells(lngRowCounter, "C") = recIn!DollarsSold
    xlReport.Cells(lngRowCounter, "D") = recIn!UnitsSold
    recIn.MoveNext
Loop Until lngRowCounter = 56

recIn.Close
Set recIn = Nothing

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "TopAndBottom25Sales_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlReport Is Nothing Then Set xlReport = Nothing
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
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


Private Sub Form_Open(Cancel As Integer)
Me.cmbUserPaths.Value = "MARCO"
Me.Page1.SetFocus
End Sub

Private Sub UpdateDailyData_Click()
' ***********************************************************************
' Create the internal tables from Adagio Data
' ***********************************************************************
    DoCmd.SetWarnings False
    DoCmd.Hourglass True
    DoCmd.OpenQuery "qryCreateCustomerMaster", acViewNormal, acEdit
    Me.boxProgress1.BackColor = 65280
    Me.Repaint
    DoCmd.OpenQuery "qryCreateItemMaster", acViewNormal, acEdit
    Me.boxProgress2.BackColor = 65280
    Me.Repaint
    DoCmd.OpenQuery "qryCreateTransHistory", acViewNormal, acEdit
    Me.boxProgress3.BackColor = 65280
    Me.Repaint
    DoCmd.OpenQuery "qryPTB_CreateRawGoodsPOsOutstanding", acViewNormal, acEdit
    Me.boxProgress4.BackColor = 65280
    Me.Repaint
    DoCmd.SetWarnings True
    Call UpdateGlobalsAtStartup
    DoCmd.Hourglass False
End Sub

Private Sub cmdPrintMonthlySalesCompare_Click()
On Error GoTo Error_Handler
' **************************************************************
' 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 xlSh As Excel.Worksheet
Dim xlSh2 As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngLoopCount As Long
Dim lngDateRowCount As Long
Dim lngTransactionDay As Long
Dim dteLatestTransDate As Date
Dim dteStartingDate As Date
Dim lngCurrentYear As Long
Dim lngHolidayYearColumn As Long
Dim dteHolidayArray(9) As Date
Dim strShadeTheDate As String
Dim lngLastYear As Long
Dim lngCurrentMonth As Long
Dim lngNumberOfDaysInMonth As Long
Dim strMarcoDateHeader As String
Dim strSaveAsName As String
Dim lngRow As Long
Dim i As Long

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "OneMonthSalesCompareTemplate.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Sales Compare Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

DoCmd.Hourglass True
' **************************************************************
' Create The Sales Compare Table
' **************************************************************
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryCreateSalesCompareOneMonthV2", acViewNormal, acEdit
DoCmd.SetWarnings True

' ***********************************************************************
' Get Date Information Required For the Report
' ***********************************************************************
dteLatestTransDate = GetMaxShipDate
lngNumberOfDaysInMonth = DateSerial(Year(dteLatestTransDate), Month(dteLatestTransDate) + 1, 1) - DateSerial(Year(dteLatestTransDate), Month(dteLatestTransDate), 1)
lngCurrentYear = Year(dteLatestTransDate)
lngLastYear = lngCurrentYear - 1
lngCurrentMonth = Month(dteLatestTransDate)
strMarcoDateHeader = MonthName(lngCurrentMonth) & " Sales " & CStr(lngCurrentYear)
dteStartingDate = DateSerial(lngCurrentYear, lngCurrentMonth, 1) - 1

' **************************************************************
' Open the Sales Compare Template
' **************************************************************
Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlSh = xlWB.Sheets("DailySalesCompare")
Set xlSh2 = xlWB.Sheets("HolidaySchedule")
' xlApp.Visible = True

' **************************************************************
' Create the column index for Holidays
' **************************************************************
lngHolidayYearColumn = lngCurrentYear - (xlSh2.Range("B3") - 2)

' **************************************************************
' See if it's time to update the calendar
' **************************************************************
If lngHolidayYearColumn > 6 Then
    MsgBox ("Time to Update the 'HolidaySchedule' Worksheet in this Workbook" & vbCrLf & "Replace the 5 years with this year and the next 4 years")
    GoTo Error_Handler_Exit
End If

' **************************************************************
' Load the Holiday Array Depending on the Year
' **************************************************************
For i = 1 To 9
    dteHolidayArray(i) = xlSh2.Cells(i + 3, lngHolidayYearColumn)
Next i

' **************************************************************
' Set up dates in the Excel Worksheet
' **************************************************************
For i = 1 To lngNumberOfDaysInMonth
    Select Case i
        Case 1 To 7
            lngRow = i + 4
            dteStartingDate = dteStartingDate + 1
            xlSh.Cells(lngRow, "A") = dteStartingDate
            If IsWorkingDay(dteStartingDate, dteHolidayArray) = "N" Then
                With xlSh.Cells(lngRow, "B").Interior
                    .ThemeColor = xlThemeColorAccent3
                    .TintAndShade = 0.399975585192419
                End With
            End If
            
        Case 8 To 14
            lngRow = i + 7
            dteStartingDate = dteStartingDate + 1
            xlSh.Cells(lngRow, "A") = dteStartingDate
            If IsWorkingDay(dteStartingDate, dteHolidayArray) = "N" Then
                With xlSh.Cells(lngRow, "B").Interior
                    .ThemeColor = xlThemeColorAccent3
                    .TintAndShade = 0.399975585192419
                End With
            End If

        Case 15 To 21
            lngRow = i + 10
            dteStartingDate = dteStartingDate + 1
            xlSh.Cells(lngRow, "A") = dteStartingDate
            If IsWorkingDay(dteStartingDate, dteHolidayArray) = "N" Then
                With xlSh.Cells(lngRow, "B").Interior
                    .ThemeColor = xlThemeColorAccent3
                    .TintAndShade = 0.399975585192419
                End With
            End If

        Case 22 To 28
            lngRow = i + 13
            dteStartingDate = dteStartingDate + 1
            xlSh.Cells(lngRow, "A") = dteStartingDate
            If IsWorkingDay(dteStartingDate, dteHolidayArray) = "N" Then
                With xlSh.Cells(lngRow, "B").Interior
                    .ThemeColor = xlThemeColorAccent3
                    .TintAndShade = 0.399975585192419
                End With
            End If

        Case Is > 28
            lngRow = i + 16
            dteStartingDate = dteStartingDate + 1
            xlSh.Cells(lngRow, "A") = dteStartingDate
            If IsWorkingDay(dteStartingDate, dteHolidayArray) = "N" Then
                With xlSh.Cells(lngRow, "B").Interior
                    .ThemeColor = xlThemeColorAccent3
                    .TintAndShade = 0.399975585192419
                End With
            End If
    End Select
Next i

' ***********************************************************************
' Open the One Month Sales Compare Query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryOneMonthSalesAnalysisSummary")

' ***********************************************************************
' Loop Through Each Record And Populate The Excel Form
' ***********************************************************************
lngLoopCount = 1

Do
If lngLoopCount = 1 Then
    lngLoopCount = lngLoopCount + 1
    xlSh.Range("A2") = strMarcoDateHeader
    xlSh.Range("B3") = MonthName(lngCurrentMonth)
    xlSh.Range("C3") = MonthName(lngCurrentMonth)
    xlSh.Range("B4") = lngCurrentYear
    xlSh.Range("C4") = lngLastYear
End If

' ***********************************************************************
' Calculate the targe row for dollars
' ***********************************************************************
lngTransactionDay = Day(recIn!TrxDate)
Select Case lngTransactionDay
    Case 1 To 7
        lngRow = lngTransactionDay + 4
    Case 8 To 14
        lngRow = lngTransactionDay + 7
    Case 15 To 21
        lngRow = lngTransactionDay + 10
    Case 22 To 28
        lngRow = lngTransactionDay + 13
    Case Is > 28
        lngRow = lngTransactionDay + 16
End Select

' ***************************************************************
' Poulate the workbook with sales dollars and returns
' ***************************************************************
If Year(recIn!TrxDate) = lngLastYear Then
    xlSh.Cells(lngRow, "C") = recIn!SalesAmount
Else
    xlSh.Cells(lngRow, "B") = recIn!SalesAmount
    xlSh.Cells(lngRow, "D") = recIn!RefundAmount
End If

NextRecord:
recIn.MoveNext
Loop Until recIn.EOF

' ***********************************************************************
' Print and Close the Workbook
' ***********************************************************************
' xlSh.PrintOut

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "DailySalesCompare_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlSh Is Nothing Then Set xlSh = Nothing
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
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

Private Function IsWorkingDay(dteDateOfMonth As Date, dteHolidayArray() As Date) As String
Dim lngWeekday As Integer
Dim j As Long

' ********************************************************
' See if it's a holiday
' ********************************************************
For j = 1 To 9
    If dteHolidayArray(j) = dteDateOfMonth Then
        IsWorkingDay = "N"
        Exit Function
    End If
Next j

' ********************************************************
' See if it's a working day (Monday through Thursday)
' ********************************************************
lngWeekday = Weekday(dteDateOfMonth)
If lngWeekday > 1 And lngWeekday < 6 Then 'Weekdays are Monday Through Thursday
    IsWorkingDay = "Y"
    Exit Function
End If

IsWorkingDay = "N"
Exit Function

End Function
Private Sub cmdPrintYearlySalesCompare_Click()
On Error GoTo Error_Handler
' **************************************************************
' 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 xlSh As Excel.Worksheet

' **************************************************************
' Other Variables
' **************************************************************
Dim lngRow As Long
Dim lngColumn As Long
Dim lngCurrentYear As Long
Dim lngLastYear As Long
Dim dteLatestTransDate As Date
Dim strMarcoDateHeader As String
Dim strSaveAsName As String

' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "OneYearSalesCompareTemplate.xlsx"

' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
    Case "MARCO"
'       strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
'       strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
        strPathToTemplates = CurDir() & "\Templates\"
        strSavePath = CurDir() & "\SavedReports\"
    Case Else
        strPathToTemplates = Me.cmbUserPaths.Column(1)
        strSavePath = Me.cmbUserPaths.Column(2)
End Select

' **************************************************************
' Verify That The Sales Compare Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
     MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
    Exit Sub
End If

' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
     MsgBox (strSavePath & " Does Not Exist")
    Exit Sub
End If

DoCmd.Hourglass True

' ***********************************************************************
' Get Date Information Required For the Report
' ***********************************************************************
dteLatestTransDate = GetMaxShipDate
lngCurrentYear = Year(dteLatestTransDate)
lngLastYear = lngCurrentYear - 1

strMarcoDateHeader = "Sales Compare For the Years " & CStr(lngLastYear) & " & " & CStr(lngCurrentYear)

' **************************************************************
' Open the Sales Compare Template
' **************************************************************
Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlSh = xlWB.Sheets("YearlySalesCompare")
' xlApp.Visible = True

' **************************************************************
' Set up Headers and Dates in the Excel Worksheet
' **************************************************************
xlSh.Range("A1") = strMarcoDateHeader
xlSh.Range("B2") = CStr(lngLastYear)
xlSh.Range("C2") = CStr(lngCurrentYear)

' ***********************************************************************
' Open the One Month Sales Compare Query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryOneYearSalesCompareStep2")

' ***********************************************************************
' Loop Through Each Record And Populate The Excel Form
' ***********************************************************************
Do
    ' ***********************************************************************
    ' Calculate the Row and Column
    ' ***********************************************************************
    If recIn!TransYear = lngLastYear Then
        lngColumn = 2
    Else
        lngColumn = 3
    End If
    
    lngRow = recIn!TransMonth + 2
    
    ' ***************************************************************
    ' Poulate the workbook with sales dollars
    ' ***************************************************************
    xlSh.Cells(lngRow, lngColumn) = recIn!SumOfSaleAmt
    
NextRecord:
    recIn.MoveNext
Loop Until recIn.EOF

' ***********************************************************************
' Print and Close the Workbook
' ***********************************************************************
' xlSh.PrintOut

' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "YearlySalesCompare_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook

' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)

Error_Handler_Exit:
DoCmd.Hourglass False
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 xlSh Is Nothing Then Set xlSh = Nothing
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
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 FileExists(FilePath As String) As Boolean
' *******************************************************************************************
' * THIS FUNCTION WILL TEST IF A FILE EXISTS                                              *
' *******************************************************************************************
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

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

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

©Logicwurks, LLC - P.O. Box 11543 Eugene, Oregon 97440 - Contact: Rich Locus