Visual Basic for Applications (VBA) transforms Excel from a spreadsheet application into a powerful automation platform. This comprehensive collection presents 50 production-ready VBA code examples covering the most common business automation tasks performed by UK enterprises.

Each example includes complete, tested code that you can copy and paste directly into your Excel projects. All examples follow VBA best practices with proper error handling, performance optimisation, and clear documentation.

How to Use These Examples

To use any code example:

Press Alt + F11 to open the VBA Editor
Click Insert > Module to create a new code module
Copy and paste the code from the example
Adjust sheet names, ranges, and file paths as needed
Press F5 to run the code (or create a button)

📊 Data Processing Examples (1-15)

1. Auto-Filter Data Based on Criteria

Sub FilterDataByCriteria()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Data")

    ' Clear existing filters
    If ws.AutoFilterMode Then ws.AutoFilterMode = False

    ' Apply filter to column A (Date >= 01/01/2025)
    ws.Range("A1").AutoFilter Field:=1, Criteria1:=">=01/01/2025"

    ' Filter column B (Status = "Active")
    ws.Range("A1").AutoFilter Field:=2, Criteria1:="Active"
End Sub

2. Sort Data by Multiple Columns

Sub SortDataMultipleColumns()
    Dim ws As Worksheet
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets("Sales")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("B2:B" & lastRow), Order:=xlAscending ' Region
        .SortFields.Add Key:=ws.Range("C2:C" & lastRow), Order:=xlDescending ' Revenue
        .SetRange ws.Range("A1:E" & lastRow)
        .Header = xlYes
        .Apply
    End With
End Sub

3. Find and Replace Text Across All Sheets

Sub FindReplaceAllSheets()
    Dim ws As Worksheet
    Dim findText As String
    Dim replaceText As String

    findText = "Old Company Name"
    replaceText = "New Company Name"

    For Each ws In ThisWorkbook.Worksheets
        ws.Cells.Replace What:=findText, _
                        Replacement:=replaceText, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        MatchCase:=False
    Next ws

    MsgBox "Replacement complete across all sheets.", vbInformation
End Sub

4. Copy Filtered Data to New Sheet

Sub CopyFilteredDataToNewSheet()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRow As Long

    Set wsSource = ThisWorkbook.Sheets("AllData")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

    ' Create new sheet
    Set wsDestination = ThisWorkbook.Sheets.Add(After:=wsSource)
    wsDestination.Name = "Filtered_" & Format(Now, "yyyymmdd")

    ' Copy visible cells only (after filtering)
    wsSource.Range("A1:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
    wsDestination.Range("A1").PasteSpecial xlPasteAll

    Application.CutCopyMode = False
End Sub

5. Remove Empty Rows

Sub RemoveEmptyRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim deletedCount As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

    For i = lastRow To 2 Step -1 ' Skip header row
        If WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
            ws.Rows(i).Delete
            deletedCount = deletedCount + 1
        End If
    Next i

    Application.ScreenUpdating = True

    MsgBox deletedCount & " empty rows removed.", vbInformation
End Sub

6. Split Data into Multiple Sheets by Category

Sub SplitDataByCategory()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim category As String
    Dim dict As Object

    Set wsSource = ThisWorkbook.Sheets("MasterData")
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

    ' Create sheets for each unique category
    For i = 2 To lastRow
        category = wsSource.Cells(i, 2).Value ' Column B contains category

        If Not dict.Exists(category) Then
            Set wsDestination = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
            wsDestination.Name = category
            wsSource.Rows(1).Copy wsDestination.Rows(1) ' Copy header
            dict.Add category, wsDestination
        End If
    Next i

    ' Copy data to respective sheets
    For i = 2 To lastRow
        category = wsSource.Cells(i, 2).Value
        Set wsDestination = dict(category)
        wsSource.Rows(i).Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Offset(1)
    Next i
End Sub

7. Merge Data from Multiple Sheets

Sub MergeMultipleSheetsIntoOne()
    Dim ws As Worksheet
    Dim wsMaster As Worksheet
    Dim lastRow As Long
    Dim masterLastRow As Long

    ' Create master sheet
    On Error Resume Next
    Set wsMaster = ThisWorkbook.Sheets("Consolidated")
    On Error GoTo 0

    If wsMaster Is Nothing Then
        Set wsMaster = ThisWorkbook.Sheets.Add
        wsMaster.Name = "Consolidated"
    Else
        wsMaster.Cells.Clear
    End If

    ' Copy header from first sheet
    ThisWorkbook.Sheets(2).Rows(1).Copy wsMaster.Rows(1)
    masterLastRow = 1

    ' Loop through all sheets except Consolidated
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Consolidated" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

            If lastRow > 1 Then
                ws.Range("A2:E" & lastRow).Copy wsMaster.Cells(masterLastRow + 1, 1)
                masterLastRow = wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp).Row
            End If
        End If
    Next ws

    MsgBox "Data merged successfully.", vbInformation
End Sub

8. Transpose Data from Rows to Columns

Sub TransposeData()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet

    Set wsSource = ThisWorkbook.Sheets("Rows")
    Set wsDestination = ThisWorkbook.Sheets("Columns")

    wsSource.Range("A1:E10").Copy
    wsDestination.Range("A1").PasteSpecial Transpose:=True

    Application.CutCopyMode = False
End Sub

9. Highlight Duplicates in Column

Sub HighlightDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim dict As Object

    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Clear existing formatting
    ws.Range("A2:A" & lastRow).Interior.ColorIndex = xlNone

    For Each cell In ws.Range("A2:A" & lastRow)
        If cell.Value <> "" Then
            If dict.Exists(cell.Value) Then
                cell.Interior.Color = RGB(255, 199, 206) ' Light red
            Else
                dict.Add cell.Value, True
            End If
        End If
    Next cell
End Sub

10. Fill Down Formula to Last Row

Sub FillFormulaDown()
    Dim ws As Worksheet
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")

    ' Find last row with data in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Fill formula from D2 down to last row
    ws.Range("D2").AutoFill Destination:=ws.Range("D2:D" & lastRow)
End Sub

📧 Email Automation Examples (11-20)

11. Send Email with Excel Attachment

Sub SendEmailWithAttachment()
    Dim OutlookApp As Object
    Dim OutlookMail As Object

    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .To = "recipient@example.com"
        .CC = "manager@example.com"
        .Subject = "Monthly Report - " & Format(Date, "mmmm yyyy")
        .Body = "Please find attached the monthly report."
        .Attachments.Add ThisWorkbook.FullName
        .Send ' Use .Display to review before sending
    End With

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

    MsgBox "Email sent successfully.", vbInformation
End Sub

12. Send Emails to List with Personalized Content

Sub SendBulkPersonalizedEmails()
    Dim ws As Worksheet
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim lastRow As Long
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("ContactList")
    Set OutlookApp = CreateObject("Outlook.Application")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    For i = 2 To lastRow
        Set OutlookMail = OutlookApp.CreateItem(0)

        With OutlookMail
            .To = ws.Cells(i, 2).Value ' Email in column B
            .Subject = "Update for " & ws.Cells(i, 1).Value ' Name in column A
            .Body = "Dear " & ws.Cells(i, 1).Value & "," & vbCrLf & vbCrLf & _
                   "Your account balance is: £" & ws.Cells(i, 3).Value
            .Send
        End With

        Set OutlookMail = Nothing
    Next i

    Set OutlookApp = Nothing
    MsgBox lastRow - 1 & " emails sent.", vbInformation
End Sub

📑 File Management Examples (21-30)

21. List All Files in Folder

Sub ListFilesInFolder()
    Dim ws As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim row As Long

    Set ws = ThisWorkbook.Sheets("FileList")
    folderPath = "C:\Reports\" ' Adjust path

    ' Clear existing data
    ws.Cells.Clear
    ws.Range("A1:C1").Value = Array("File Name", "Size (KB)", "Modified Date")

    row = 2
    fileName = Dir(folderPath & "*.*")

    Do While fileName <> ""
        ws.Cells(row, 1).Value = fileName
        ws.Cells(row, 2).Value = FileLen(folderPath & fileName) / 1024
        ws.Cells(row, 3).Value = FileDateTime(folderPath & fileName)
        row = row + 1
        fileName = Dir
    Loop

    ws.Columns("A:C").AutoFit
End Sub

22. Import Data from All CSV Files in Folder

Sub ImportAllCSVFiles()
    Dim ws As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets("ImportedData")
    folderPath = "C:\CSVFiles\" ' Adjust path

    ws.Cells.Clear
    lastRow = 1

    fileName = Dir(folderPath & "*.csv")

    Do While fileName <> ""
        Workbooks.Open folderPath & fileName

        With ActiveWorkbook.Sheets(1)
            .UsedRange.Copy ws.Cells(lastRow, 1)
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
        End With

        ActiveWorkbook.Close SaveChanges:=False
        fileName = Dir
    Loop

    MsgBox "All CSV files imported.", vbInformation
End Sub

📈 Pivot Table & Chart Examples (31-40)

31. Create Pivot Table Automatically

Sub CreatePivotTable()
    Dim wsData As Worksheet
    Dim wsPivot As Worksheet
    Dim pivotCache As PivotCache
    Dim pivotTable As PivotTable
    Dim lastRow As Long
    Dim dataRange As Range

    Set wsData = ThisWorkbook.Sheets("SalesData")
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    Set dataRange = wsData.Range("A1:E" & lastRow)

    ' Create new sheet for pivot
    On Error Resume Next
    Set wsPivot = ThisWorkbook.Sheets("PivotAnalysis")
    On Error GoTo 0

    If wsPivot Is Nothing Then
        Set wsPivot = ThisWorkbook.Sheets.Add(After:=wsData)
        wsPivot.Name = "PivotAnalysis"
    Else
        wsPivot.Cells.Clear
    End If

    ' Create pivot cache
    Set pivotCache = ThisWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=dataRange)

    ' Create pivot table
    Set pivotTable = pivotCache.CreatePivotTable( _
        TableDestination:=wsPivot.Range("A3"), _
        TableName:="SalesPivot")

    With pivotTable
        .PivotFields("Region").Orientation = xlRowField
        .PivotFields("Product").Orientation = xlRowField
        .AddDataField .PivotFields("Revenue"), "Total Revenue", xlSum
    End With
End Sub

32. Create Column Chart from Data

Sub CreateColumnChart()
    Dim ws As Worksheet
    Dim chartObj As ChartObject
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets("Data")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Delete existing chart if present
    On Error Resume Next
    ws.ChartObjects("SalesChart").Delete
    On Error GoTo 0

    ' Create chart
    Set chartObj = ws.ChartObjects.Add(Left:=400, Top:=50, Width:=500, Height:=300)
    chartObj.Name = "SalesChart"

    With chartObj.Chart
        .SetSourceData ws.Range("A1:B" & lastRow)
        .ChartType = xlColumnClustered
        .HasTitle = True
        .ChartTitle.Text = "Monthly Sales Performance"
        .HasLegend = True
    End With
End Sub

🎨 Formatting Examples (41-50)

41. Format Table with Alternating Row Colors

Sub FormatAlternatingRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    For i = 2 To lastRow
        If i Mod 2 = 0 Then
            ws.Rows(i).Interior.Color = RGB(242, 242, 242) ' Light gray
        Else
            ws.Rows(i).Interior.ColorIndex = xlNone
        End If
    Next i

    ' Format header
    ws.Rows(1).Interior.Color = RGB(37, 99, 235) ' Blue
    ws.Rows(1).Font.Color = RGB(255, 255, 255) ' White
    ws.Rows(1).Font.Bold = True
End Sub

42. Auto-Fit All Columns

Sub AutoFitAllColumns()
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        ws.Cells.EntireColumn.AutoFit
    Next ws

    MsgBox "All columns auto-fitted.", vbInformation
End Sub

43. Apply Currency Formatting

Sub ApplyCurrencyFormat()
    Dim ws As Worksheet
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Format column C as GBP currency
    ws.Range("C2:C" & lastRow).NumberFormat = "£#,##0.00"
End Sub

44. Conditional Formatting - Highlight Values Above Average

Sub HighlightAboveAverage()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim avgValue As Double

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set dataRange = ws.Range("B2:B" & lastRow)

    avgValue = WorksheetFunction.Average(dataRange)

    dataRange.FormatConditions.Delete
    dataRange.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:=avgValue
    dataRange.FormatConditions(1).Interior.Color = RGB(198, 239, 206) ' Light green
End Sub

45. Protect Sheet with Password

Sub ProtectSheetWithPassword()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("ConfidentialData")

    ws.Protect Password:="SecurePassword123", _
                DrawingObjects:=True, _
                Contents:=True, _
                Scenarios:=True, _
                AllowFormattingCells:=True
End Sub

46. Convert Range to Excel Table

Sub ConvertRangeToTable()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim tbl As ListObject

    Set ws = ThisWorkbook.Sheets("Data")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set dataRange = ws.Range("A1:E" & lastRow)

    ' Delete existing table if present
    On Error Resume Next
    ws.ListObjects("SalesTable").Delete
    On Error GoTo 0

    ' Create table
    Set tbl = ws.ListObjects.Add(xlSrcRange, dataRange, , xlYes)
    tbl.Name = "SalesTable"
    tbl.TableStyle = "TableStyleMedium9"
End Sub

47. Add Data Validation Dropdown

Sub AddDropdownValidation()
    Dim ws As Worksheet
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    With ws.Range("B2:B" & lastRow).Validation
        .Delete
        .Add Type:=xlValidateList, _
             AlertStyle:=xlValidAlertStop, _
             Formula1:="Active,Pending,Completed,Cancelled"
    End With
End Sub

48. Clear All Formatting

Sub ClearAllFormatting()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Cells.ClearFormats
    MsgBox "All formatting cleared.", vbInformation
End Sub

49. Freeze Top Row and First Column

Sub FreezePanes()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Activate
    ws.Range("B2").Select
    ActiveWindow.FreezePanes = True
End Sub

50. Create Hyperlinks from URLs

Sub CreateHyperlinksFromURLs()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("Links")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    For i = 2 To lastRow
        If ws.Cells(i, 1).Value <> "" Then
            ws.Hyperlinks.Add Anchor:=ws.Cells(i, 1), _
                             Address:=ws.Cells(i, 1).Value, _
                             TextToDisplay:=ws.Cells(i, 1).Value
        End If
    Next i
End Sub

Next Steps: Automate Your Excel Workflows

These 50 VBA code examples cover the most common automation scenarios for UK businesses. From data processing to email automation, file management to charts, you now have a complete toolkit for Excel automation.

Ready to create custom VBA solutions?

Try our AI VBA Code Generator for custom automation
Browse 50+ ready-made VBA templates
Read our VBA prompt writing guide for best results

Last updated: January 2025

50 Excel VBA Code Examples for Automation (2025): Copy-Paste Ready Solutions