There is a newer version of this template now available, here: http://stott.asia/macro-enabled-purchase-order-template-2/
I was asked to come up with a simple purchase order system for our team to use, which would hopefully automate the process a little. We needed:
- Unique purchase order number on each request
- Reduce the number of manual steps required to get approval from line manager
- Provide centralised logging & archive of purchase orders raised
I rehashed a bit of the code from one of my previous posts (Word VBA Macro > Create Doc to Email), and borrowed a few bits from other code – a download is available below. Tabs 2, 3 and 4 are just plain text entries, adding more values to these lists will make them available on the main sheet.
Download PurchaseOrderTemplate.rar (160kb):
Download
You will also need to add a reference to the Microsoft Office 14.0 Object Library from within Excel, and enable macros for this to work. Hope this template or some part of the code is useful to you. Row 43 & column i can be hidden from the Master spreadsheet, I have left them visible as you may wish to amend the formulas
The Process Explained:
- The user opens Purchase Order Master.xlsx. The PO number automatically increments by one & the file saves
- User enters the details as required to the form. Once completed, the user his the Generate Purchase Order button
- Email is generated & a PDF copy attached. Email is addressed To: {Approval field}; Cc: {Requested By field}
- If there is a value inserted to the Service Request field, then our servicedesk@company.com address is CC’d to the email, and the SR# is added to the subject line for email integration
- The PDF is written to disk, using the variables from the spreadsheet & today’s date/time for the filename to ensure no accidental file overwrites
- The summary on row 43 is copied & pasted to the Purchase Order Log.xlsx sheet
- The purchase order is copied as a range & pasted to the email ready to send
- User closes the workbook without saving changes (leaving the blank template ready for other staff)
- In order to raise two consecutive PO’s, simply hit the ‘Reset Fields’ button to wipe input data, and increment to the next PO number
You should then be presented with your PO request email, ready to send:

And your log spreadsheet should have a new row inserted for the current Purchase Order:

The Macros Explained:
Workbook_Open, inserted to ThisWorkbook. Increments the Purchase Order number in cell B6 by 1 & saves the file, whenever the file is opened. This is to prevent duplicate purchase order numbers being used, occasionally one will be skipped but as long as there are no duplicates, then it’s fine:
Private Sub Workbook_Open()
Range("B6") = Range("B6") + 1
ActiveWorkbook.Save
End Sub
Mandatory_fields: the ‘Generate’ button is linked directly to this macro – Assuming all the specified cells have values, it will call the Mail_Sheet_Outlook_Body macro in order to continue:
Sub Mandatory_fields()
'Check Mandatory Fields
If Range("B10").Value = "" Then
MsgBox "'Supplier' is a mandatory field...", vbOKOnly, "Required Field"
Exit Sub
ElseIf Range("B8").Value = "" Then
MsgBox "'Cost Code' is a mandatory field...", vbOKOnly, "Required Field"
Exit Sub
ElseIf Range("B22").Value = "" Then
MsgBox "'Requested By' is a mandatory field...", vbOKOnly, "Required Field"
Exit Sub
ElseIf Range("B24").Value = "" Then
MsgBox "'Approval' is a mandatory field...", vbOKOnly, "Required Field"
Exit Sub
End If
'If all required fields are met, then process main macro & generate documentation
Call Mail_Sheet_Outlook_Body
End Sub
Mail_Sheet_Outlook_Body: The main portion of the macro – Sets all the required cell values to strings which are then used to create the email To:, CC:, and Subject, file name etc, generates the PDF output locally & dumps a copy into the Archive folder. Brings up an Outlook window & attaches the PDF file, and inserts the email addresses etc:
Sub Mail_Sheet_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim MailSub As String
Dim MailSub2 As String
Dim Supplier As String
Dim PONumber As String
Dim ToAddress As String
Dim CCAddress As String
Dim CCAddress2 As String
Dim CCAddress3 As String
Dim SRNumber As String
Dim fname As String
Dim strdata As String
Dim sSource As String
Dim sDestination As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = Range("A1:E24")
ToAddress = Range("B24")
CCAddress = Range("B22")
CCAddress2 = Range("i10")
CCAddress3 = CCAddress & "; " & CCAddress2
Supplier = Range("B10")
PONumber = Range("I4")
SRNumber = Range("e6")
MailSub2 = "New " & Supplier & " Purchase Order Raised: " & PONumber & " SR: #" & SRNumber
todaydate = Format(Date, "d-mmm-yy")
nowtime = Format(Time, "hhmm")
fname = "PO#" & PONumber & "_-" & todaydate & "_" & nowtime & "(" & Supplier & ")"
'Generate PDF document to c:\
strdata = "c:\Purchase Orders\" & fname & ".pdf"
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strdata, Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
'Create Mail & attach PDF
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If
'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.To = ToAddress
.CC = CCAddress3
.Subject = MailSub2
.HTMLBody = RangetoHTML(rng)
'Bring up new mail window
oItem.Display
'Add attachment
oItem.Attachments.Add strdata
'Move PDF Document to network drive
sSource = strdata
sDestination = "c:\Purchase Orders\Archive\" & fname & ".pdf"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.movefile sSource, sDestination
'Cleanup, baby
Set OutMail = Nothing
Set OutApp = Nothing
End With
End Sub
RangetoHTML – Copies the worksheet range to HTML:
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
Call UpDateLog
End Function
UpDateLog: Opens the Purchase Order Log.xlsx file and inserts the details of the current row into the spreadsheet & saves:
Sub UpDateLog()
Dim wb As Workbook, wbTemp As Workbook
Dim ws As Worksheet, wsTemp As Worksheet
Dim lastRow As Long
'Setting source workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("Template")
'Setting destination workbook
Set wbTemp = Workbooks.Open("c:\Purchase Orders\Purchase Order Log.xlsx")
Set wsTemp = wbTemp.Sheets("Sheet1")
'Paste to next row as values to preserve data
lastRow = wsTemp.Range("I" & Rows.Count).End(xlUp).Row + 1
ws.Range("A43:K43").Copy
wsTemp.Range("I" & lastRow).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
'Cleanup
wbTemp.Close savechanges:=True
Set wb = Nothing: Set wbTemp = Nothing
Set ws = Nothing: Set wsTemp = Nothing
End Sub
ResetFields: Wipes all user input data, setting the form back to default. Also runs the PO number increment code, in order to prevent one user raising two separate purchase orders with the same log number:
Sub ResetFields()
'
' ResetFields Macro
Range("E6").Select
Selection.ClearContents
Range("B8").Select
Selection.ClearContents
Range("B10").Select
Selection.ClearContents
Range("E6").Select
Selection.ClearContents
Range("A13:D13").Select
Selection.ClearContents
Range("A14:D14").Select
Selection.ClearContents
Range("A15:D15").Select
Selection.ClearContents
Range("A16:D16").Select
Selection.ClearContents
Range("A17:D17").Select
Selection.ClearContents
Range("A18:D18").Select
Selection.ClearContents
Range("A19:D19").Select
Selection.ClearContents
Range("A20:D20").Select
Selection.ClearContents
Range("E21").Select
Selection.ClearContents
Range("B24").Select
Selection.ClearContents
Range("B22").Select
Selection.ClearContents
Range("A1").Select
Range("B6") = Range("B6") + 1
ActiveWorkbook.Save
End Sub
