Interface Excel With Access
This is the code for an Access Application that generates many Excel reports using formatted Excel Tempaltes as the source for populating the data. Among the features is the creation of the My Documents path while getting the username necessary for the path. Many other features are also included that perform special formatting of the Excel templates.
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
Dim dblValuationCostAddition As Double
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
Dim rngRangeToSort As Range
' **************************************************************
' 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
' **************************************************************
Set db = CurrentDb()
' ***********************************************************************
' Create FMP and N22 Equivalent UOM's for Raw Goods
' ***********************************************************************
db.Execute "qryMPS_UpdateFMP_N22_RawGoodEquiv", dbFailOnError
Call CreateFMP_N22RawGoodsQtys
' ***********************************************************************
' Build the Projected to Buy Table
' ***********************************************************************
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 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
' ********************************************************
' SORT THE WORKSHEET BY NET ALLOWANCE
' ********************************************************
Set rngRangeToSort = xlReport.Range(xlReport.Cells(4, 1), xlReport.Cells(lngRowCounter, 17))
With xlReport.Sort
.SortFields.Clear
.SortFields.Add Key:= _
xlReport.Columns("K"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.SetRange rngRangeToSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
' ********************************************************
' 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 = "LoadAnalysisTemplateV2.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 cmdEditLabelCharacteristics_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryLabelItemNumbersTable", acViewNormal, acEdit
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 cmdEnter2019Budget_Click()
DoCmd.OpenQuery "qryEnter2019Budget", acViewNormal, acEdit
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
Dim xlLabelComponents As Excel.Worksheet
' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter As Long
Dim strSaveAsName As String
Dim strAppendLastYearQuery As String
Dim strAppendMPS_TableQuery As String
Dim dblLeadTime As Double
Dim strStatus As String
Dim strSortOrder As String
Dim dblMonthsInStock As Double
Dim dteExpectedDate As Date
Dim lngNumberOfRows As Long
Dim rngRangeToSort As Range
Dim rngHighlightNegatives As Range
' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "MonthlyProductionScheduleV9.xlsx"
DoCmd.Hourglass True
' **************************************************************
' 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")
DoCmd.Hourglass False
Exit Sub
End If
' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
MsgBox (strSavePath & " Does Not Exist")
DoCmd.Hourglass False
Exit Sub
End If
' ***********************************************************************
' Open the Monthly Production Schedule Query
' ***********************************************************************
Set db = CurrentDb()
' ***********************************************************************
' Create FMP and N22 Equivalent UOM's for Raw Goods
' ***********************************************************************
db.Execute "qryMPS_UpdateFMP_N22_RawGoodEquiv", dbFailOnError
Call CreateFMP_N22RawGoodsQtys
' **************************************************************
' Update the MPS Conversion Table
' **************************************************************
DoCmd.SetWarnings False
' **************************************************************
' qryMPS_LastYearMthlyAvgSales
' Makes table tblMPS_AverageMthlySalesByItem
' This looks at the last 12 months of sales transaction history
' **************************************************************
strAppendLastYearQuery = "qryMPS_LastYearMthlyAvgSales"
' **************************************************************
' qryMPS_MonthlyProductionScheduleAppendTable
' Appends table tblMPS_MonthlyProductionSchedule
' This also looks at Raw Goods
' Includes:
' Item (Only Finished Goods), Description, Monthly Turn Rate,
' QtyOnHand,SupplyInMonths, Raw Goods on Hand, Amount to Run,
' Production Time
' **************************************************************
strAppendMPS_TableQuery = "qryMPS_MonthlyProductionScheduleAppendTable"
db.Execute "qryMPS_PurgeMonthlyProductionScheduleTable", dbFailOnError
DoCmd.DeleteObject acTable, "tblMPS_AverageMthlySalesByItem"
DoCmd.DeleteObject acTable, "tblMPS_PORawGoodsAllocation"
db.Execute strAppendLastYearQuery, dbFailOnError
db.Execute "qryMPS_PurgeMonthlyProductionScheduleTable", dbFailOnError
db.Execute strAppendMPS_TableQuery, dbFailOnError
' **************************************************************
' Update the FMP and N22 Raw Goods Units
' **************************************************************
db.Execute "qryMPS_UpdateMasterFMP_N22Units", dbFailOnError
db.Execute "qryMPS_PORawGoodsAllocationMakeTable", dbFailOnError
db.Execute "qryMPS_UpdateMonthlyProductionSchedule", dbFailOnError
DoCmd.SetWarnings True
Set recIn = db.OpenRecordset("qryMPS_MonthlyProductionScheduleTable", dbOpenSnapshot)
If recIn.RecordCount = 0 Then
GoTo Error_Handler_Exit
End If
' **************************************************************
' 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("NonLabelBOMComponents")
Set xlLabelComponents = xlWB.Sheets("LabelBOMComponents")
' xlApp.Visible = True
' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Monthly Production Schedule As Of " & Date
xlOtherComponents.Range("A1") = "BOM Non-Label Other Components As Of " & Date
xlLabelComponents.Range("A1") = "BOM Label Other Components As Of " & Date
' ***************************************************************
' POPULATE THE FIRST WORKSHEET
' ***************************************************************
' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 4
Do
lngRowCounter = lngRowCounter + 1
' ***************************************************************
' Determine the Status
' ***************************************************************
If recIn!QtyOnHand <= 0 Then
strStatus = "Backorder"
strSortOrder = "A"
GoTo PopulateExcel
End If
' ***************** Compute Months in Stock *****************
If recIn!MonthlyTRBottles = 0 Then
dblMonthsInStock = 0.5
Else
dblMonthsInStock = recIn!QtyOnHand / recIn!MonthlyTRBottles
End If
' ***************** Get Expected Arrival Date *****************
If IsDate(recIn!POExpectedByDate) Then
dteExpectedDate = recIn!POExpectedByDate
Else
dteExpectedDate = #1/1/1900#
End If
If recIn!QtyOnHand > 0 And recIn!RGOnHand = 0 Then
If dteExpectedDate <> #1/1/1900# Then
' ***************** No Raw Goods But Expected PO Arrivals *****************
Select Case dblMonthsInStock
Case Is < 1
strStatus = "<1 Month Stock Until " & dteExpectedDate + 10
strSortOrder = "H"
Case Is < 2
strStatus = "<2 Months Stock Until " & dteExpectedDate + 10
strSortOrder = "I"
Case Is < 3
strStatus = "<3 Months Stock Until " & dteExpectedDate + 10
strSortOrder = "J"
Case Else
strStatus = ""
strSortOrder = ""
End Select
Else
' ***************** No Raw Goods And No Raw Goods On PO *****************
Select Case dblMonthsInStock
Case Is < 1
strStatus = "<1 Month In Stock None On Order"
strSortOrder = "E"
Case Is < 2
strStatus = "<2 Month In Stock None On Order"
strSortOrder = "F"
Case Is < 3
strStatus = "<3 Month In Stock None On Order"
strSortOrder = "G"
Case Else
strStatus = ""
strSortOrder = ""
End Select
End If
GoTo PopulateExcel
End If
' ***************** No Raw Goods And No Raw Goods On PO *****************
If recIn!QtyOnHand > 0 And recIn!RGOnHand > 0 Then
Select Case dblMonthsInStock
Case Is < 1
strStatus = "High Priority Production"
strSortOrder = "B"
Case Is < 2
strStatus = "Medium Priority Production"
strSortOrder = "C"
Case Is < 3
strStatus = "Low Priority Production"
strSortOrder = "D"
Case Else
strStatus = ""
strSortOrder = ""
End Select
End If
' ***************************************************************
' Poulate the workbook with Scheduling Data
' ***************************************************************
PopulateExcel:
xlReport.Cells(lngRowCounter, "A") = recIn!Item
xlReport.Cells(lngRowCounter, "B") = recIn!Description
xlReport.Cells(lngRowCounter, "C") = recIn!QtyOnHand
xlReport.Cells(lngRowCounter, "D") = recIn!MonthlyTRBottles * 3
xlReport.Cells(lngRowCounter, "E") = recIn!QtyOnHand - (recIn!MonthlyTRBottles * 3)
xlReport.Cells(lngRowCounter, "F") = recIn!RGOnHand
xlReport.Cells(lngRowCounter, "G") = recIn!MonthlyTRBottles
xlReport.Cells(lngRowCounter, "H") = recIn!RawGoodItem
xlReport.Cells(lngRowCounter, "I") = recIn!RawGoodsOnPO
xlReport.Cells(lngRowCounter, "J") = recIn!POExpectedByDate
xlReport.Cells(lngRowCounter, "K") = recIn!ProductionTime
xlReport.Cells(lngRowCounter, "L") = strStatus
xlReport.Cells(lngRowCounter, "M") = strSortOrder
GetNextRecord:
recIn.MoveNext
Loop Until recIn.EOF
recIn.Close
Set recIn = Nothing
' ********************************************************
' SORT THE WORKSHEET BY PRODUCTION PRIORITY
' ********************************************************
lngNumberOfRows = xlReport.Cells(xlReport.Rows.Count, "A").End(xlUp).Row
Set rngRangeToSort = xlReport.Range(xlReport.Cells(5, 1), xlReport.Cells(lngNumberOfRows, 13))
With xlReport.Sort
.SortFields.Clear
.SortFields.Add Key:= _
xlReport.Columns("M"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.SortFields.Add Key:= _
xlReport.Columns("G"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
.SetRange rngRangeToSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
' ********************************************************
' Highlight Negative Values
' ********************************************************
Set rngHighlightNegatives = xlReport.Range(xlReport.Cells(5, 3), xlReport.Cells(lngNumberOfRows, 11))
rngHighlightNegatives.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
Formula1:="=0"
rngHighlightNegatives.FormatConditions(rngHighlightNegatives.FormatConditions.Count).SetFirstPriority
With rngHighlightNegatives.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With rngHighlightNegatives.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
rngHighlightNegatives.FormatConditions(1).StopIfTrue = False
' ********************************************************
' POPULATE THE 2ND WORKSHEET WITH "OTHER" ITEMS
' ********************************************************
Set recIn = db.OpenRecordset("qryMPS_NonRawGoodsVarianceNoLabels", 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!OnPO
xlOtherComponents.Cells(lngRowCounter, "G") = recIn!MinimumOH
xlOtherComponents.Cells(lngRowCounter, "H") = recIn!MaximumOH
xlOtherComponents.Cells(lngRowCounter, "I") = recIn!MOQ
If Not IsNull(recIn!LeadTime) Then
dblLeadTime = recIn!LeadTime
xlOtherComponents.Cells(lngRowCounter, "J") = dblLeadTime
End If
recIn.MoveNext
Loop Until recIn.EOF
' ********************************************************
' POPULATE THE 3RD WORKSHEET WITH LABELS
' ********************************************************
recIn.Close
Set recIn = Nothing
' ********************************************************
' Create the 3rd Worksheet Data Table
' ********************************************************
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryLabelDeleteLabelMonthlyProdSchedule", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelLoadMonthlyProductionSchedule", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateOpenPurchaseOrders", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateLabelTotal", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateRGBottlesOnHand", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateBottlesOnOpenPO", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateRawBottleTotal", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateEndPosition", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateMonthlyTurnRate", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateMOQ", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateMinMax", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateBuyPlan", acViewNormal, acEdit
DoCmd.OpenQuery "qryLabelUpdateFGSupplyAndMonths", acViewNormal, acEdit
DoCmd.SetWarnings True
Set recIn = db.OpenRecordset("qryMPS_NonRawGoodsVarianceLabels", 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
' ***************************************************************
xlLabelComponents.Cells(lngRowCounter, "A") = recIn!LabelItem
xlLabelComponents.Cells(lngRowCounter, "B") = recIn!Description
xlLabelComponents.Cells(lngRowCounter, "C") = recIn!LBLOnHand
xlLabelComponents.Cells(lngRowCounter, "D") = recIn!LBLOnPO
xlLabelComponents.Cells(lngRowCounter, "E") = recIn!LBLTotal
xlLabelComponents.Cells(lngRowCounter, "F") = recIn!RGBottlesOnHand
xlLabelComponents.Cells(lngRowCounter, "G") = recIn!RGBottlesOnPO
xlLabelComponents.Cells(lngRowCounter, "H") = recIn!RGBottlesTotal
xlLabelComponents.Cells(lngRowCounter, "I") = recIn!LBLEndPosition
xlLabelComponents.Cells(lngRowCounter, "J") = recIn!MonthlyTurnRate
xlLabelComponents.Cells(lngRowCounter, "K") = recIn!LBLMinimum
xlLabelComponents.Cells(lngRowCounter, "L") = recIn!LBLMaximum
xlLabelComponents.Cells(lngRowCounter, "M") = recIn!MOQ
xlLabelComponents.Cells(lngRowCounter, "N") = recIn!FinishedGoodsInStock
xlLabelComponents.Cells(lngRowCounter, "O") = recIn!FGMonthsInStock
xlLabelComponents.Cells(lngRowCounter, "P") = recIn!BuyPlan
With xlLabelComponents.Cells(lngRowCounter, "E").Interior
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
End With
With xlLabelComponents.Cells(lngRowCounter, "H").Interior
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
End With
With xlLabelComponents.Cells(lngRowCounter, "I").Interior
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
End With
With xlLabelComponents.Cells(lngRowCounter, "N").Interior
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
End With
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 cmdFinishedGoodsTurnRates_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 = "FinishedGoodsTurnRatesTemplateV1.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 Finished Goods Turn Rate 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 /Finished Goods Turn Rate Report
' **************************************************************
' ***********************************************************************
' Open the Finished Goods Turn Rate Query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryFinishedGoodsTurnRatesWithDollars", dbOpenSnapshot)
If recIn.RecordCount = 0 Then
GoTo Error_Handler_Exit
End If
' **************************************************************
' Open the Finished Goods Turn Rate Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("FinishedGoodsTurnRates")
' xlApp.Visible = True
' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Finished Goods Turn Rates 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
' ***************************************************************
' Poulate the workbook with the Finished Goods Turn Rates
' ***************************************************************
xlReport.Cells(lngRowCounter, "A") = recIn!Item
xlReport.Cells(lngRowCounter, "B") = recIn!Description
xlReport.Cells(lngRowCounter, "C") = recIn!Last12MonthsUnitSales
xlReport.Cells(lngRowCounter, "D") = recIn!MonthlyTRBottles
xlReport.Cells(lngRowCounter, "E") = recIn!BasePrice
xlReport.Cells(lngRowCounter, "F") = recIn!MthlyIncomePotential
recIn.MoveNext
Loop Until recIn.EOF
' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "FinishedGoodsTurnRates_" & 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 cmdVendorPONotification_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 strLastVendorNumber As String
Dim strLastVendorName 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 = "OpenPurchaseOrdersEmailTemplateV1.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
' ***********************************************************************
' 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("qryOpenPurchaseOrdersForVendorConfirmation", dbOpenSnapshot)
If recIn.RecordCount = 0 Then
GoTo Error_Handler_Exit
End If
' ***********************************************************************
' Initialize Control Fields
' ***********************************************************************
strLastVendorNumber = recIn!VendorNumber
strLastVendorName = recIn!ShortVendorName
' **************************************************************
' 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") = "Vendor Open Purchase Orders As Of " & Date
' ***************************************************************
' Loop through all the query records for each vendor and
' produce a separate report for each vendor
' ***************************************************************
lngRowCounter = 2
Do
FormatVendorExcel:
lngRowCounter = lngRowCounter + 1
' ***************************************************************
' If the Vendor Is The Same Create New Excel Row
' ***************************************************************
If recIn!VendorNumber = strLastVendorNumber Then
' ***************************************************************
' 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") = 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!ShipVia
xlReport.Cells(lngRowCounter, "K") = recIn!EstimatedShipDate
Else
' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & strLastVendorName & "OpenPurchaseOrdersConfirmation_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook
' ********************************************************
' Initialize For The Next Vendor
' ********************************************************
strLastVendorNumber = recIn!VendorNumber
strLastVendorName = recIn!ShortVendorName
lngRowCounter = 3
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
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("OpenPurchaseOrders")
xlReport.Range("A1") = "Vendor Open Purchase Orders As Of " & Date
' ***************************************************************
' 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") = 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!ShipVia
xlReport.Cells(lngRowCounter, "K") = recIn!EstimatedShipDate
recIn.MoveNext
If recIn.EOF Then
GoTo FinishReport
Else
GoTo FormatVendorExcel
End If
End If
recIn.MoveNext
Loop Until recIn.EOF
FinishReport:
' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & strLastVendorName & "OpenPurchaseOrdersConfirmation_" & 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 Vendor Notification Reports Were Saved to " & strSavePath)
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 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
Call GetValuationAdditionFromDB
Forms![AdagioControlPanel]![txtValuationAddition] = dblGlobalValuationAddition
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 cmdInventoryValuationReport_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 rngSubtotal As Range
Dim rngBorders As Range
Dim rngTotals As Range
Dim rngReplaceWithZeroes As Range
Dim rngHighlightNegatives As Range
Dim C As Range
' **************************************************************
' Validate The Inventory Unit Valuation Overhead Addition
' **************************************************************
If Not IsNumeric(Forms![AdagioControlPanel]![txtValuationAddition]) Then
MsgBox ("Overhead Valuation Addition Is Not Numeric")
Exit Sub
End If
dblGlobalValuationAddition = CDec(Forms![AdagioControlPanel]![txtValuationAddition])
Call PutValuationAdditionToDB
' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "InventoryValuationTemplateV3.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
' ***********************************************************************
' Get Overhead Addition for Inventory Valuation Report
' Open the Valuation Cost Addition Table
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("tblValuationCostAddition")
If recIn.EOF Then
MsgBox ("No Valuation Record Found in tblValuationCostAddition")
dblValuationCostAddition = 0
GoTo CloseTable
End If
dblValuationCostAddition = recIn!ValuationCostAddition
CloseTable:
recIn.Close
Set recIn = Nothing
Set db = Nothing
' **************************************************************
' Create the Projected To Buy Table With Today's Data
' **************************************************************
Call CreateValuationTable(dblValuationCostAddition)
' ***********************************************************************
' Open the Valuation Table
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryValuationFinalReport", 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("ValuationFinalReport")
' xlApp.Visible = True
' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Inventory Valuation Including Raw Materials and On Order 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 the Projected To Buy Balances
' ***************************************************************
If recIn!Item = "MSB" Or _
recIn!Item = "NSB" Or _
recIn!Item = "RPD" Or _
recIn!Item = "RPD12" Or _
recIn!Item = "RPD4" Or _
recIn!Item = "RPD6" Or _
recIn!Item = "RPI" Or _
recIn!Item = "RPI12" Or _
recIn!Item = "RPI4" Or _
recIn!Item = "RPI6" Then
lngRowCounter = lngRowCounter - 1
GoTo GetNextRow
End If
xlReport.Cells(lngRowCounter, "A") = recIn!Item
xlReport.Cells(lngRowCounter, "B") = recIn!Description
xlReport.Cells(lngRowCounter, "C") = recIn!InvBasePrice
xlReport.Cells(lngRowCounter, "D") = recIn!InvMostRecentCost
xlReport.Cells(lngRowCounter, "E") = recIn!InvQtyonHand1
xlReport.Cells(lngRowCounter, "F") = recIn!InvAdagioTotalcost
xlReport.Cells(lngRowCounter, "G") = recIn!InvComputedTotalCost
xlReport.Cells(lngRowCounter, "H") = recIn!InvLargerOfCosts
xlReport.Cells(lngRowCounter, "I") = recIn!InvLargerCostEach
xlReport.Cells(lngRowCounter, "J") = recIn!InvTotalRetailValue
xlReport.Cells(lngRowCounter, "K") = recIn!RGComputedQtyOnHand
xlReport.Cells(lngRowCounter, "L") = recIn!RGComputedTotalCost
xlReport.Cells(lngRowCounter, "M") = recIn!RGComputedRetailValue
xlReport.Cells(lngRowCounter, "N") = recIn!POComputedQtyOnHand
xlReport.Cells(lngRowCounter, "O") = recIn!POComputedTotalCost
xlReport.Cells(lngRowCounter, "P") = recIn!POComputedRetailValue
xlReport.Cells(lngRowCounter, "Q") = recIn!GrandTotalComputedCost
xlReport.Cells(lngRowCounter, "R") = recIn!GrandTotalRetailValue
GetNextRow:
recIn.MoveNext
Loop Until recIn.EOF
' ********************************************************
' Create Subtotals
' ********************************************************
Set rngSubtotal = xlReport.Range(xlReport.Cells(lngRowCounter + 1, 8), xlReport.Cells(lngRowCounter + 1, 8))
rngSubtotal.FormulaR1C1 = "=SUM(R[-" & lngRowCounter - 4 & "]C:R[-1]C)"
Set rngSubtotal = xlReport.Range(xlReport.Cells(lngRowCounter + 1, 10), xlReport.Cells(lngRowCounter + 1, 10))
rngSubtotal.FormulaR1C1 = "=SUM(R[-" & lngRowCounter - 4 & "]C:R[-1]C)"
Set rngSubtotal = xlReport.Range(xlReport.Cells(lngRowCounter + 1, 12), xlReport.Cells(lngRowCounter + 1, 13))
rngSubtotal.FormulaR1C1 = "=SUM(R[-" & lngRowCounter - 4 & "]C:R[-1]C)"
Set rngSubtotal = xlReport.Range(xlReport.Cells(lngRowCounter + 1, 15), xlReport.Cells(lngRowCounter + 1, 18))
rngSubtotal.FormulaR1C1 = "=SUM(R[-" & lngRowCounter - 4 & "]C:R[-1]C)"
' ********************************************************
' Create Vertical Row Highlights as Thick Lines
' ********************************************************
Set rngBorders = xlReport.Range(xlReport.Cells(5, 11), xlReport.Cells(lngRowCounter, 11))
With rngBorders.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Set rngBorders = xlReport.Range(xlReport.Cells(5, 14), xlReport.Cells(lngRowCounter, 14))
With rngBorders.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Set rngBorders = xlReport.Range(xlReport.Cells(5, 17), xlReport.Cells(lngRowCounter, 17))
With rngBorders.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
' ********************************************************
' On Totals Line, Color Blue, Bold Font and Total Footers
' ********************************************************
Set rngTotals = xlReport.Range(xlReport.Cells(lngRowCounter + 1, 3), xlReport.Cells(lngRowCounter + 1, 18))
With rngTotals.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
rngTotals.Font.Bold = True
With rngTotals.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
' ********************************************************
' Replace any empty cells with zeroes
' ********************************************************
Set rngReplaceWithZeroes = xlReport.Range(xlReport.Cells(5, 3), xlReport.Cells(lngRowCounter, 18))
For Each C In rngReplaceWithZeroes
If C.Value = "" Then
C.Value = 0
End If
Next C
' ********************************************************
' Highlight Negative Values
' ********************************************************
Set rngHighlightNegatives = xlReport.Range(xlReport.Cells(5, 3), xlReport.Cells(lngRowCounter, 18))
rngHighlightNegatives.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
Formula1:="=0"
rngHighlightNegatives.FormatConditions(rngHighlightNegatives.FormatConditions.Count).SetFirstPriority
With rngHighlightNegatives.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With rngHighlightNegatives.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
rngHighlightNegatives.FormatConditions(1).StopIfTrue = False
' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "InventoryValuation_" & 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 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
If dteStartingDate = #12/31/2018# Then
dteStartingDate = #1/1/2019#
End If
' **************************************************************
' 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 = "OneYearSalesCompareTemplateV2.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)
xlSh.Range("D2") = CStr(lngCurrentYear) & " Budget"
' ***********************************************************************
' Create Yearly Compare Table
' ***********************************************************************
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryDeleteSalesCompareWithBudget"
DoCmd.OpenQuery "qryAppendOneYearSalesCompareStep2"
DoCmd.OpenQuery "qryAppendSalesCompareBudget"
DoCmd.SetWarnings True
' ***********************************************************************
' Open the One Month Sales Compare Query
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryOneYearSalesCompareTable")
' ***********************************************************************
' Loop Through Each Record And Populate The Excel Form
' ***********************************************************************
Do
' ***********************************************************************
' Calculate the Row and Column
' ***********************************************************************
If recIn!TransYear = lngLastYear Then
lngColumn = 2
ElseIf recIn!TransYear = lngCurrentYear Then
lngColumn = 3
Else: lngColumn = 4
End If
lngRow = recIn!TransMonth + 2
' ***********************************************************************
' Blank out the current month's difference column
' ***********************************************************************
If recIn!TransMonth = Month(Date) Then
xlSh.Cells(lngRow, 5) = ""
End If
' ***************************************************************
' 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