Access Macro to create new word and excel documents from templates

[Deekappa]

Hi All,

I'm new to Access, so I'll apologise now if this is a silly question.

Currently, I use an Excel template to put together detailed Building and Construction quotes. I want to use Access as a database for all our quotes.

Is it possible to enter the data in to Access, and have a macro which would then create a new folder containing a new excel workbook, based on a template?

I know how to do this with Excel, but I don't know if this is possible with Access.

Any help would be much appreciated.

 

[welshgasman]

Yes, quite easy if you know Excel VBA as well.
You would open an Excel object from within Access. Here is some code that I wrote to create a workbook for employee hours, new leavers and starters to send to the accountants for payroll.

HTH

Sub Export2XL(pdtDateWE, pblnMail As Boolean, pblnEdit As Boolean)
On Error GoTo Err_Handler


Dim db As Database
Dim xlApp As Excel.Application
Dim xlWrkBk As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim rstPR As Recordset, rstNS As Recordset, rstNL As Recordset, rstSD As Recordset
Dim strSQL As String, strSQLDate As String, strDBpath As String, strFolder As String, strExportPath As String, strSQLPayments As String
Dim strEmail As String, strXLTemplate As String, strXLFile As String, strSubject As String, strMessage As String, strSubjectEmail As String
Dim strStartDate As String, strSuffix As String
Dim lSubmitterID As Long, lxlRow As Long
Dim strTestPrefix As String
Dim blnEmail As Boolean
Dim curPaid As Currency, curAdvance As Currency, curPrevious As Currency, curInvoice As Currency, curAdj As Currency
'Const strcJetDate = "\#mm\/dd\/yyyy\#"  'Needed for dates in queries as Access expects USA format.Now Public


' Set for testing, remove when live
strTestPrefix = ""
strSubject = strTestPrefix & "Payroll Data - Heartleys"
strMessage = "Please find attached the latest employee data for payroll WE " & pdtDateWE
strEmail = "emailname@emaildomain.com"

Set db = CurrentDb()
strDBpath = Left(GetBackEndPath, InStrRev(GetBackEndPath, "\"))
strSQLDate = Format(pdtDateWE, strcJetDate)
strStartDate = Format(DateAdd("d", -6, pdtDateWE), strcJetDate)


'Create new folder if it does not exist
strSuffix = Format(pdtDateWE, "yyyy-mm-dd")
strExportPath = strDBpath & "Payroll" & "\"


' Set up XL file names
strXLTemplate = "Payroll Template.xlsx"
strXLFile = strSuffix & " - " & "Payroll Data.xlsx"


' Test for path to save files, created each week.
If Dir(strExportPath, vbDirectory) = "" Then
    MkDir strExportPath
End If




'Open and reference an instance of the Excel app
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False


' Get all the records for week ending date
strSQL = "SELECT tblPayroll.*, [Forename] & ' ' & [Surname] AS Fullname"
strSQL = strSQL & " FROM tblEmployee INNER JOIN tblPayroll ON tblEmployee.EmployeeID = tblPayroll.EmployeeID"
strSQL = strSQL & " WHERE (((tblPayroll.DateWE)=" & strSQLDate & "))"


Set rstPR = db.OpenRecordset(strSQL, dbOpenDynaset)


' Any records to process?
If rstPR.EOF Then
    MsgBox "No records found for " & pdtDateWE
    GoTo ExitSub
End If


'Update status bar with progress
SetStatusBar ("Exporting payroll records to Excel file ")


rstPR.MoveFirst


' Open the Excel Template file
Set xlWrkBk = xlApp.Workbooks.Open(strExportPath & strXLTemplate)
'reference the first sheet in the file
Set xlSht = xlWrkBk.Sheets(1)
xlSht.Cells(2, 1) = rstPR![DateWE]
lxlRow = 3
Do While Not rstPR.EOF
    ' Now enter values in sheet
    xlSht.Cells(lxlRow, 2) = rstPR![FullName]
    xlSht.Cells(lxlRow, 3) = rstPR![BasicHours]
    xlSht.Cells(lxlRow, 4) = rstPR![OTHours]
    xlSht.Cells(lxlRow, 5) = rstPR![HolidayHours]
    xlSht.Cells(lxlRow, 6) = rstPR![BankHolidayHours]
    xlSht.Cells(lxlRow, 7) = rstPR![SickHours]
    xlSht.Cells(lxlRow, 8) = rstPR![Commission]
    xlSht.Cells(lxlRow, 9) = rstPR![BonusAmt]
    lxlRow = lxlRow + 1
    ' Now update the Processed date
     With rstPR
         .Edit
         ![Processed] = Date
         .Update
    End With
    rstPR.MoveNext
Loop
rstPR.Close
xlSht.Columns("A:Z").EntireColumn.AutoFit


' Now check for any starters
strSQL = "SELECT tblLookUp.DataValue AS RealTitle, tblEmployee.* "
strSQL = strSQL & " FROM tblEmployee LEFT JOIN tblLookup ON tblEmployee.Title = tblLookup.LookupID"
strSQL = strSQL & " WHERE (((tblEmployee.StartDate) Between " & strStartDate & " And " & strSQLDate & "))"


'Update status bar with progress
SetStatusBar ("Looking for new Starters")


Set rstNS = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rstNS.EOF Then
    Set xlSht = xlWrkBk.Sheets(2)
    lxlRow = 2
    rstNS.MoveFirst
    Do While Not rstNS.EOF
        xlSht.Cells(lxlRow, 1) = rstNS![RealTitle]
        xlSht.Cells(lxlRow, 2) = rstNS![Forename]
        xlSht.Cells(lxlRow, 3) = rstNS![Surname]
        xlSht.Cells(lxlRow, 4) = rstNS![Address1]
        xlSht.Cells(lxlRow, 5) = rstNS![Address2]
        xlSht.Cells(lxlRow, 6) = rstNS![Address3]
        xlSht.Cells(lxlRow, 7) = rstNS![Address4]
        xlSht.Cells(lxlRow, 8) = rstNS![Address5]
        xlSht.Cells(lxlRow, 9) = rstNS![PostCode]
        xlSht.Cells(lxlRow, 10) = rstNS![DOB]
        xlSht.Cells(lxlRow, 11) = rstNS![NINO]
        xlSht.Cells(lxlRow, 12) = rstNS![BasicRate]
        xlSht.Cells(lxlRow, 13) = rstNS![StartDate]
        lxlRow = lxlRow + 1
        rstNS.MoveNext
    Loop
    MsgBox "New Starter(s) found. Remember to forward HMRC Checklist Forms"
    rstNS.Close
    xlSht.Columns("A:Z").EntireColumn.AutoFit
End If




' Now check for any leavers
strSQL = "SELECT tblLookUp.DataValue AS RealTitle, tblEmployee.* "
strSQL = strSQL & " FROM tblEmployee LEFT JOIN tblLookup ON tblEmployee.Title = tblLookup.LookupID"
strSQL = strSQL & " WHERE (((tblEmployee.EndDate) Between " & strStartDate & " And " & strSQLDate & "))"


'Update status bar with progress
SetStatusBar ("Looking for new Leavers")


Set rstNL = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rstNL.EOF Then
    Set xlSht = xlWrkBk.Sheets(3)
    lxlRow = 2
    rstNL.MoveFirst
    Do While Not rstNL.EOF
        xlSht.Cells(lxlRow, 1) = rstNL![RealTitle]
        xlSht.Cells(lxlRow, 2) = rstNL![Forename]
        xlSht.Cells(lxlRow, 3) = rstNL![Surname]
        xlSht.Cells(lxlRow, 4) = rstNL![EndDate]
        xlSht.Cells(lxlRow, 5) = rstNL![HolidaysLeft]
       
        lxlRow = lxlRow + 1
        rstNL.MoveNext
    Loop
    MsgBox "New leaver(s) found. Check remaining Holidays in Excel sheet"
    rstNL.Close
    xlSht.Columns("A:Z").EntireColumn.AutoFit
End If


'Update status bar with progress
SetStatusBar ("Looking for sick dates to report")


strSQL = "SELECT tblLookup.DataValue, tblLookup.LookupID, tblEmployeeDay.EmployeeID, tblEmployeeDay.DayID, tblEmployee.Forename, tblEmployee.Surname, tblDates.DayDate"
strSQL = strSQL & " FROM ((tblLookup INNER JOIN tblEmployeeDay ON tblLookup.LookupID = tblEmployeeDay.DateType) INNER JOIN tblEmployee ON tblEmployeeDay.EmployeeID = tblEmployee.EmployeeID) INNER JOIN tblDates ON tblEmployeeDay.DayDate = tblDates.DayDate"
strSQL = strSQL & " WHERE (((tblLookup.DataValue)='Sick Day') AND ((tblDates.DayDate) Between " & strStartDate & " And " & strSQLDate & "))"
strSQL = strSQL & " ORDER BY tblEmployee.Forename, tblEmployee.Surname, tblDates.DayDate;"


Set rstSD = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rstSD.EOF Then
    Set xlSht = xlWrkBk.Sheets(4)
    lxlRow = 2
    rstSD.MoveFirst
    Do While Not rstSD.EOF
        xlSht.Cells(lxlRow, 1) = rstSD![Forename]
        xlSht.Cells(lxlRow, 2) = rstSD![Surname]
        xlSht.Cells(lxlRow, 3) = rstSD![DayDate]
        lxlRow = lxlRow + 1
        rstSD.MoveNext
    Loop
    MsgBox "Sick Days added in Excel sheet"
    rstSD.Close
    xlSht.Columns("A:Z").EntireColumn.AutoFit
End If
xlWrkBk.Sheets(1).Activate ' So when Workbook is opened we have first sheet


' Now autofit columns
'xlSht.Visible = xlSheetVisible
'xlSht.Columns("A:Z").EntireColumn.AutoFit
SetStatusBar ("Saving Excel workbook " & strXLFile)
' Now save the workbook
xlWrkBk.SaveAs FileName:=strExportPath & strXLFile
xlWrkBk.Close
'Now email the workbook to the Submitter if tempvars gbEmail is true
If pblnMail Then
     Call Mail_Attachment(strEmail, strExportPath & strXLFile, strSubject, strMessage, pblnEdit)
End If








ExitSub:
    xlApp.DisplayAlerts = True
    Set db = Nothing
    Set rstPR = Nothing
    Set rstNS = Nothing
    Set rstNL = Nothing
    Set rstSD = Nothing
    Set xlSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    SetStatusBar (" ")


    
Err_Exit:
    Exit Sub
    
Err_Handler:
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume ExitSub
End Sub

 

[Deekappa]

Awesome, thanks for the help!