{Stott.Asia}

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