Automated Report Generation Intermediate

Purchase Order Generator

Create professional purchase orders with supplier lookup, automatic totals, approval tracking, and order history logging. Includes sequential PO numbering and PDF export capability.

405 views

Perfect For:

Procurement management
Supplier ordering
Purchase tracking
Order approval workflows
Spending control

VBA Code

' Purchase Order Generator
' Suppliers sheet: SupplierID (A), Name (B), Address (C), Contact (D), Email (E), Terms (F)
' PO sheet: Purchase order form layout
' PO Log sheet: Historical record of all POs

Sub CreatePurchaseOrder()
    ' Generate a new purchase order
    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False

    Dim wsPO As Worksheet
    Dim wsSuppliers As Worksheet
    Dim wsLog As Worksheet

    Set wsPO = ThisWorkbook.Sheets("Purchase Order")

    On Error Resume Next
    Set wsSuppliers = ThisWorkbook.Sheets("Suppliers")
    Set wsLog = ThisWorkbook.Sheets("PO Log")
    On Error GoTo ErrorHandler

    If wsSuppliers Is Nothing Then
        MsgBox "Please create a 'Suppliers' sheet with columns: SupplierID, Name, Address, Contact, Email, Terms", vbExclamation
        Exit Sub
    End If

    ' Create PO Log if it doesn't exist
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsLog.Name = "PO Log"
        wsLog.Cells(1, 1).Value = "PO Number"
        wsLog.Cells(1, 2).Value = "Date"
        wsLog.Cells(1, 3).Value = "Supplier"
        wsLog.Cells(1, 4).Value = "Total"
        wsLog.Cells(1, 5).Value = "Status"
        wsLog.Cells(1, 6).Value = "Approved By"

        With wsLog.Range("A1:F1")
            .Font.Bold = True
            .Interior.Color = RGB(0, 102, 204)
            .Font.Color = RGB(255, 255, 255)
        End With
    End If

    ' Clear previous PO
    wsPO.Range("A8:F50").ClearContents
    wsPO.Range("A8:F50").ClearFormats

    ' Generate PO number
    Dim poNumber As String
    Dim lastPONum As Long
    Dim lastLogRow As Long
    lastLogRow = wsLog.Cells(wsLog.Rows.Count, "A").End(xlUp).Row

    If lastLogRow > 1 Then
        ' Extract number from last PO
        Dim lastPO As String
        lastPO = wsLog.Cells(lastLogRow, 1).Value
        lastPONum = Val(Replace(lastPO, "PO-", ""))
    End If

    lastPONum = lastPONum + 1
    poNumber = "PO-" & Format(lastPONum, "0000")

    ' PO Header
    wsPO.Range("A1").Value = "PURCHASE ORDER"
    wsPO.Range("A1").Font.Size = 20
    wsPO.Range("A1").Font.Bold = True
    wsPO.Range("A1").Font.Color = RGB(0, 102, 204)

    wsPO.Range("D1").Value = "PO Number:"
    wsPO.Range("E1").Value = poNumber
    wsPO.Range("E1").Font.Bold = True

    wsPO.Range("D2").Value = "Date:"
    wsPO.Range("E2").Value = Format(Date, "dd/mm/yyyy")

    wsPO.Range("D3").Value = "Required By:"
    Dim requiredDate As String
    requiredDate = InputBox("Enter required delivery date (dd/mm/yyyy):", "Delivery Date", Format(DateAdd("d", 14, Date), "dd/mm/yyyy"))
    If requiredDate = "" Then requiredDate = Format(DateAdd("d", 14, Date), "dd/mm/yyyy")
    wsPO.Range("E3").Value = requiredDate

    ' Select supplier
    Dim supplierName As String
    supplierName = InputBox("Enter supplier name:", "Supplier")
    If supplierName = "" Then Exit Sub

    ' Look up supplier
    Dim lastSupRow As Long
    lastSupRow = wsSuppliers.Cells(wsSuppliers.Rows.Count, "A").End(xlUp).Row

    Dim supplierFound As Boolean
    Dim supplierRow As Long

    Dim i As Long
    For i = 2 To lastSupRow
        If LCase(wsSuppliers.Cells(i, 2).Value) = LCase(supplierName) Then
            supplierFound = True
            supplierRow = i
            Exit For
        End If
    Next i

    ' Write supplier details
    wsPO.Range("A3").Value = "Supplier:"
    wsPO.Range("A3").Font.Bold = True

    If supplierFound Then
        wsPO.Range("A4").Value = wsSuppliers.Cells(supplierRow, 2).Value
        wsPO.Range("A5").Value = wsSuppliers.Cells(supplierRow, 3).Value
        wsPO.Range("A6").Value = "Contact: " & wsSuppliers.Cells(supplierRow, 4).Value
    Else
        wsPO.Range("A4").Value = supplierName
        wsPO.Range("A5").Value = "(Supplier not in database)"
    End If

    ' Line item headers
    Dim headerRow As Long
    headerRow = 8

    wsPO.Cells(headerRow, 1).Value = "Item #"
    wsPO.Cells(headerRow, 2).Value = "Description"
    wsPO.Cells(headerRow, 3).Value = "Quantity"
    wsPO.Cells(headerRow, 4).Value = "Unit"
    wsPO.Cells(headerRow, 5).Value = "Unit Price"
    wsPO.Cells(headerRow, 6).Value = "Line Total"

    With wsPO.Range("A" & headerRow & ":F" & headerRow)
        .Font.Bold = True
        .Interior.Color = RGB(0, 102, 204)
        .Font.Color = RGB(255, 255, 255)
    End With

    ' Enter line items
    Dim itemRow As Long
    itemRow = headerRow + 1
    Dim subtotal As Double
    Dim itemNum As Long

    Do
        Dim itemDesc As String
        itemDesc = InputBox("Enter item description (leave blank to finish):", "Item " & (itemRow - headerRow))
        If itemDesc = "" Then Exit Do

        Dim itemQty As Double
        itemQty = Val(InputBox("Enter quantity:", "Quantity", "1"))

        Dim itemUnit As String
        itemUnit = InputBox("Enter unit (each, box, kg, etc.):", "Unit", "each")

        Dim itemPrice As Double
        itemPrice = Val(InputBox("Enter unit price:", "Unit Price"))

        itemNum = itemNum + 1
        wsPO.Cells(itemRow, 1).Value = itemNum
        wsPO.Cells(itemRow, 1).HorizontalAlignment = xlCenter
        wsPO.Cells(itemRow, 2).Value = itemDesc
        wsPO.Cells(itemRow, 3).Value = itemQty
        wsPO.Cells(itemRow, 3).HorizontalAlignment = xlCenter
        wsPO.Cells(itemRow, 4).Value = itemUnit
        wsPO.Cells(itemRow, 4).HorizontalAlignment = xlCenter
        wsPO.Cells(itemRow, 5).Value = itemPrice
        wsPO.Cells(itemRow, 5).NumberFormat = "#,##0.00"
        wsPO.Cells(itemRow, 6).Value = itemQty * itemPrice
        wsPO.Cells(itemRow, 6).NumberFormat = "#,##0.00"

        subtotal = subtotal + (itemQty * itemPrice)
        itemRow = itemRow + 1
    Loop

    ' Totals
    Dim totalsRow As Long
    totalsRow = itemRow + 1

    Dim vatRate As Double
    vatRate = 0.2

    wsPO.Cells(totalsRow, 5).Value = "Subtotal:"
    wsPO.Cells(totalsRow, 5).Font.Bold = True
    wsPO.Cells(totalsRow, 6).Value = subtotal
    wsPO.Cells(totalsRow, 6).NumberFormat = "#,##0.00"

    wsPO.Cells(totalsRow + 1, 5).Value = "VAT (20%):"
    wsPO.Cells(totalsRow + 1, 5).Font.Bold = True
    wsPO.Cells(totalsRow + 1, 6).Value = subtotal * vatRate
    wsPO.Cells(totalsRow + 1, 6).NumberFormat = "#,##0.00"

    Dim grandTotal As Double
    grandTotal = subtotal + (subtotal * vatRate)

    wsPO.Cells(totalsRow + 2, 5).Value = "TOTAL:"
    wsPO.Cells(totalsRow + 2, 5).Font.Bold = True
    wsPO.Cells(totalsRow + 2, 5).Font.Size = 13
    wsPO.Cells(totalsRow + 2, 6).Value = grandTotal
    wsPO.Cells(totalsRow + 2, 6).NumberFormat = "#,##0.00"
    wsPO.Cells(totalsRow + 2, 6).Font.Bold = True
    wsPO.Cells(totalsRow + 2, 6).Font.Size = 13

    ' Terms and conditions
    wsPO.Cells(totalsRow + 4, 1).Value = "Terms & Conditions:"
    wsPO.Cells(totalsRow + 4, 1).Font.Bold = True

    If supplierFound Then
        wsPO.Cells(totalsRow + 5, 1).Value = "Payment Terms: " & wsSuppliers.Cells(supplierRow, 6).Value
    Else
        wsPO.Cells(totalsRow + 5, 1).Value = "Payment Terms: Net 30 days"
    End If

    wsPO.Cells(totalsRow + 7, 1).Value = "Authorised By: ___________________________"
    wsPO.Cells(totalsRow + 8, 1).Value = "Date: ___________________________"

    ' Log the PO
    lastLogRow = wsLog.Cells(wsLog.Rows.Count, "A").End(xlUp).Row + 1
    wsLog.Cells(lastLogRow, 1).Value = poNumber
    wsLog.Cells(lastLogRow, 2).Value = Format(Date, "dd/mm/yyyy")
    wsLog.Cells(lastLogRow, 3).Value = supplierName
    wsLog.Cells(lastLogRow, 4).Value = grandTotal
    wsLog.Cells(lastLogRow, 4).NumberFormat = "#,##0.00"
    wsLog.Cells(lastLogRow, 5).Value = "Pending"

    ' Auto-fit
    wsPO.Columns("A:F").AutoFit
    wsPO.Columns("B").ColumnWidth = 35

    Application.ScreenUpdating = True

    MsgBox "Purchase Order " & poNumber & " created!" & vbCrLf & _
           "Total: " & Format(grandTotal, "#,##0.00"), vbInformation

    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    MsgBox "Error creating PO: " & Err.Description, vbCritical
End Sub

Need Custom VBA Solutions?

Our AI-powered VBA generator can create custom code tailored to your specific requirements in seconds.

Generate Custom VBA Code View Plans & Pricing

Free AI generations every month — top up with credit packs anytime

Related Templates

More VBA templates in the same category

Advanced

Dashboard Creator

Create interactive dashboards with charts and key metrics

View Template

Advanced

Survey Feedback Processor

Complete solution for processing survey feedback: clean data, create individual sheets per person...