Recording macros

Looking at the code

Ways of running macros

Where macros are stored

Reasons to write macros

Writing macros

Procedure types

Visual Basic editor (VBE)

Rules & conventions

Excel objects

Range/Selection objects

Object hierarchy

Object browser

Chart objects

Pivot Table objects


Visual Basic Functions

Creating Add-Ins

Variables & constants

Object variables



Message Box

VBA Input Box

Excel Input Box

Making decisions (If)

Making decisions (Case)

Looping (Do...Loop)

Looping (For...Loop)

With...End With blocks

User defined functions

Event handling

Error handling


Creating User Forms

DAO/ADO Objects

Input/Output Files


Other links

Example code snippets

Userform input example






Example Code - Snippets

Now that you have (hopefully) reviewed the previous articles on this website VBA reference guide, you may want to browse some example snippets of code which can be used to build up your knowledge and personal library of Excel VBA.


The following links will take you to a particular section to help you find some reference that maybe of interest to you (which can be as simple as a one line piece of code):

Used range of cells - worksheet protection by value type

Basic calculation (Sum) in a range of cells

Nested For...Next with an If statement

Loop through worksheets in a workbook for set ranges

Worksheet - hidden and visible properties

Inserting worksheets avoiding duplicate names, naming & validations

InputBox and Message Box examples

Printing examples

General application commands

Ranges - various examples

Navigation in a worksheet using Offset

Read Window documents

General function examples

Creates a new word document

Creates an Outlook message



Used range of cells - worksheet protection by value type

This sub procedure looks at every cell on the active worksheet and if the cell does not have a formula, a date or text and the cell is numeric; it unlocks the cell and makes the font blue. 

For everything else, it locks the cell and makes the font black.  It then protects the worksheet.

This has the effect of allowing someone to edit the numbers but they cannot change the text, dates or formulas.

Sub SetProtection()
    On Error GoTo errorHandler

    Dim myDoc As Worksheet
    Dim cel As Range
    Set myDoc = ActiveSheet
    For Each cel In myDoc.UsedRange
        If Not cel.HasFormula And _
                           Not TypeName(cel.Value) = "Date" And _
                                          Application.IsNumber(cel) Then
            cel.Locked = False
            cel.Font.ColorIndex = 5
            cel.Locked = True
            cel.Font.ColorIndex = xlColorIndexAutomatic
       End If
    Exit Sub

     MsgBox "Error"
End Sub


Back to top


Basic calculation (Sum) in a range of cells

Enters a value into 10 cells in a column and then sums the values (range) using the sum function.

Sub SumRange()
    Dim i As Integer
    Dim cel As Range
    Set cel = ActiveCell
    For i = 1 To 10
        cel(i).Value = 100
    Next i
    cel(i).Value = "=SUM(R[-10]C:R[-1]C)"
End Sub

Other functions can be used as well as changing the range and values to suit.


Another way to write a formula:

Sub CalculateFormula()
    Dim s As String
    ActiveCell.Formula = "=" & _
        ActiveCell.Offset(0, -3).Address(False, False) & "/6"
    s = ActiveCell.Offset(0, -16).Address(False, False) _
        & ":" & ActiveCell.Offset(0, -5).Address(False, False) _
            ActiveCell.Formula = "=SUM(" & s & ")/12"
    ActiveCell.Formula = s

End Sub


Back to top


Nested For...Next with an If statement

This sub checks values in a range of 10 rows by 5 columns moving left to right, top to bottom, switching the values ‘X’ and ‘O’.

Set a range of 10 x 5 cells with a mixture of ‘X’s and ‘O’s.

Sub ToggleValues()
    Dim rowIndex As Integer
    Dim colIndex As Integer

    For rowIndex = 1 To 10
        For colIndex = 1 To 5
            If Cells(rowIndex, colIndex).Value = "X" Then
                Cells(rowIndex, colIndex).Value = "O"
                Cells(rowIndex, colIndex).Value = "X"
            End If
        Next colIndex
    Next rowIndex
End Sub


Back to top


Loop through worksheets in a workbook for set ranges

Loops through all worksheets in a workbook and reset values in a specific range(s) on each worksheet to zero where it is not a formula and the cell value is not equal to zero.

Sub SetValuesAllSheets()
    Dim wSht As Worksheet
    Dim myRng As Range
    Dim allwShts As Sheets
    Dim cel As Range

    Set allwShts = Worksheets
    For Each wSht In allwShts
        Set myRng = wSht.Range("A1:A5, B6:B10, C1:C5, D4:D10")
        For Each cel In myRng
            If Not cel.HasFormula And cel.Value <> 0 Then
                cel.Value = 0
            End If
        Next cel
    Next wSht
End Sub

Change the ranges using a comma separator for each union range.

Modify the condition and its returning value to suit.


Back to top


Worksheet - hidden and visible properties

The distinction between Hide(False) and the xlVeryHidden constant.

Visible = xlVeryHidden - Sheet/Unhide is greyed out. To unhide sheet, you must set the Visible property to True.

Visible = Hide(or False) - Sheet/Unhide is not greyed out


To hide specific (second) worksheet

Sub HideSheet()
    Worksheets(2).Visible = Hide  'you can use Hide or False
End Sub

To make a specific (second) worksheet very hidden

Sub VeryHiddenSheet()
    Worksheets(2).Visible = xlVeryHidden 'menu item is not available
End Sub

To unhide a specific worksheet

Sub UnHideSheet()
    Worksheets(2).Visible = True 
End Sub

To toggle between hidden and visible

Sub ToggleHiddenVisible()
    Worksheets(2).Visible = Not Worksheets(2).Visible
End Sub

Toggle opposite visibility (error will happen as all worksheets cannot be hidden, at least one must be visible in a workbook).

Sub ToggleAllSheets()
    On Error Goto errorHandler
    Dim wSh As Worksheet
    For Each wSh In Worksheets
        wSh.Visible = Not wSh.Visible
    Exit Sub

End Sub

To set the visible property to True on all sheets in a workbook.

Sub UnHideAll()
    Dim wSh As Worksheet

    For Each sh In Worksheets
        wSh.Visible = True

End Sub


Back to top


Inserting worksheets avoiding duplicate names, naming & validations

Checks to see if sheet already exists with the name ‘MySheet’ and does not add it again as Excel cannot store duplicate worksheet names in a workbook.

Validation if name already exists or no name stored or if it is a number as its name.

Sub AddUniqueSheet()
    Dim ws As Worksheet
    Dim newSheetName As String

    newSheetName = "MySheet" 'Substitute your name here
    For Each ws In Worksheets
        If ws.Name = newSheetName Or newSheetName = "" Or _
                                       IsNumeric(newSheetName) Then
            MsgBox "Sheet '" & newSheetName & "' already exists _
                                      or name is invalid", vbInformation
            Exit Sub
        End If
    Sheets.Add Type:="Worksheet"
    With ActiveSheet 'Move to last position
        .Move After:=Worksheets(Worksheets.Count)
        .Name = newSheetName
    End With

End Sub


Adds new worksheet with the month and year as its name and sets the range("A1:A5") from Sheet1 to new worksheet.

This can only be executed once for the same period due to excel not allowing duplicate worksheets names.

Make sure you have a worksheet called ‘Sheet1’ and that its range ‘A1:A5’ has some content which to copy across.

Sub AddSheet()
    Dim wSht As Worksheet
    Dim shtName As String
    shtName = Format(Now, "mmmm_yyyy") 'current month & year
    For Each wSht In Worksheets
        If wSht.Name = shtName Then
            MsgBox "Sheet already exists...Make necessary corrections _
                                                         and try again."
            Exit Sub
        End If
    Next wSht
    Sheets.Add.Name = shtName
    Sheets(shtName).Move After:=Sheets(Sheets.Count)
    Sheets("Sheet1").Range("A1:A5").Copy _
                 Sheets(shtName).Range("C1") 'range("C1") = starting point

End Sub


Copies the contents of the first positioned worksheet to a new worksheet (‘NewSheet’) validating if sheet exists first.

Sub CopySheet()
    Dim wSht As Worksheet
    Dim shtName As String

    shtName = "NewSheet" 'change the name if required
    For Each wSht In Worksheets
        If wSht.Name = shtName Then
            MsgBox "Sheet already exists...Make necessary " & _
                                            "corrections and try again."
            Exit Sub
        End If

    Next wSht
    Sheets(1).Copy Before:=Sheets(1)
    Sheets(1).Name = shtName
    Sheets(shtName).Move After:=Sheets(Sheets.Count)
End Sub

Index number for a sheet can be used instead of the actual string name. This is useful if name is not known or you want to control the order position of the sheet in question.


Back to top


InputBox and Message Box examples

Sub CalcPay()
    On Error GoTo HandleError

    Dim hours
    Dim payPerWeek

    hours = InputBox("Please enter number of hours worked", "Hours Worked")
    hourlyPay = InputBox("Please enter hourly pay", "Pay Rate")
    payPerWeek = CCur(hours * hourlyPay)
    MsgBox "Pay is: " & Format(payPerWeek, "£##,##0.00"), , "Total Pay" HandleError: 'any error - gracefully end

End Sub

No communication with Excel is required for this example and can be started from within the VB Editor.


To split a single line of execution into multiple lines, use the underscore character ( _ ).


What impact will this have if you use the integer function (Int()) instead of the currency functions (CCur)?

Other functions: CDbl (double) and CSng (single).


Date Entry & Formula with InputBox which prompts the user for the number of times to iterate, creates heading and calculates gross values with final totals at the end of the columns.

Sub ProcessTransactions()
    ActiveCell.Value = "NET"
    ActiveCell.Offset(0, 1).Value =
    "GROSS" ActiveCell.Offset(1, 0).Select

    y = InputBox("How Many transactions?", , 5)
    For counter = 1 To y
        x = InputBox("Enter Net")
        ActiveCell.Value = x
        ActiveCell.NumberFormat = "#,##0.00"
        ActiveCell.Offset(0, 1).FormulaR1C1 = "=RC[-1]*1.175"
        ActiveCell.Offset(0, 1).NumberFormat = "£ 0.00"
        ActiveCell.Offset(1, 0).Select
    Next counter

    ActiveCell.FormulaR1C1 = "=SUM(R[-" & y & "]C:R[-1]C)"
    'Variable y concatenated to formula (Sum)
    ActiveCell.Offset(0, 1).FormulaR1C1 = "=SUM(R[-" & y & "]C:R[-1]C)"
    Selection.Font.Bold = True

    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
End Sub

The above is A For Next Example with InputBox Function, With Block and Offset method


Back to top


Printing examples

To control orientation and defined name range - 1 copy.

Sub PrintReport1()
    Sheets(1).PageSetup.Orientation = xlLandscape
    Range("Report").PrintOut Copies:=1

End Sub


To print several ranges on the same sheet -1 copy

Sub PrintReport2()

End Sub


To print a defined area, centre horizontally, with 2 rows as titles, in portrait orientation and fitted to page wide and tall - 1 copy.

Sub PrintReport3()
    With Worksheets("Sheet1")
        .CenterHorizontally = True
        .PrintArea = "$A$3:$F$15"
        .PrintTitleRows = ("$A$1:$A$2")
        .Orientation = xlPortrait
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With

End Sub


To print preview, control the font and to pull second line of header (“A1”) from first worksheet.

Sub PrintHeaderPreview()
    ActiveSheet.PageSetup.CenterHeader = "&""Arial,Bold Italic""&14 _
        My Report" & Chr(13) & Sheets(1).Range("A1")

End Sub

"&""Arial,Bold Italic""&14 = fields used in page set-up of header/footer


Back to top


General application commands

Using the shortcut approach to assign a cell with an Excel function.

Sub GetSum()
    [A1].Value = Application.Sum([E1:E15])
End Sub

Can use an absolute reference: Range("A1") = Application.Sum([E1:E15])



Enables the use of events if disabled (worksheet/workbook).

Sub EnableEventReset()
    Application.EnableEvents = True
End Sub


To display the full path and filename of the current workbook (Function)

Sub FormatHeader()
    With ThisWorkbook
        .Worksheets("MySheet").PageSetup.LeftHeader = .FullName
    End With

End Sub


 Capture object (chart) into as separate file
Sub ExportToJPG()
    ActiveChart.Export FileName:="c:\Mychart.jpeg", FilterName:="JPG"
End Sub
 Make sure chart is selected first
 Add a custom button to the ‘Chart’ quick access toolbar.


Assign and un-assign a function key to a procedure

Sub Set_FKeys()
    Application.OnKey "{F3}", "MySub"
End Sub


Sub Restore_FKeys()
    Application.OnKey "{F3}"
End Sub

Can be assigned to the event of when a workbook opens a closes.



Sub ShowHourGlass()
    Application.Cursor = xlWait
End Sub


Sub ResetCursor()
    Application.Cursor = xlNormal
End Sub

Can also be xlNorthwestArrow and xlIBeam.


Some more to finish off with...

With ActiveWindow
    .DisplayGridlines = Not .DisplayGridlines
    .DisplayHeadings = Not .DisplayHeadings
    .DisplayHorizontalScrollBar = Not .DisplayHorizontalScrollBar
    .DisplayVerticalScrollBar = Not .DisplayVerticalScrollBar
    .DisplayWorkbookTabs = Not .DisplayWorkbookTabs


With ActiveWindow
    .DisplayFormulaBar = Not .DisplayFormulaBar
    .DisplayStatusBar = Not .DisplayStatusBar


Selection.Clear 'clears all attributes
Selection.ClearFormats 'clears only formats
Selection.ClearContents 'clears only content (DEL)


Active cell moves I row, 1 column in for selection

Sub ActiveCellInRange()
    Selection.Offset(1, 1).Activate



Back to top


Ranges - various examples

To add a range name for known range

Sub AddName1()
    ActiveSheet.Names.Add Name:="MyRange1", RefersTo:="=$A$1:$B$10"
End Sub


To add a range name based on a selection.

Sub AddName2()
    ActiveSheet.Names.Add Name:="MyRange2", RefersTo:="=" & _

End Sub


To add a range name based on a selection using a variable.

Sub AddName3()
    Dim rng As String

    rng = Selection.Address
    ActiveSheet.Names.Add Name:="MyRange3", RefersTo:="=" & rng

End Sub


To add a range name based on current selection.

Sub AddName4()
    Selection.Name = "MyRange4"
End Sub


Deletes all named ranges

Sub DeleteAllRanges()
    Dim rName As Name
    For Each rName In ActiveWorkbook.Names
    Next rName

End Sub


Scrolls the spreadsheet to where the active cell is.

Sub ScreeTopLeft()
    With ActiveWindow
        .ScrollColumn = ActiveCell.Column
        .ScrollRow = ActiveCell.Row
    End With

End Sub


Function to return a range object.

Function LastCell(ws As Worksheet) As Range
    Dim LastRow As Long, LastCol As Long
    'Error-handling is here in case there is not any
    'data in the worksheet

    On Error Resume Next

    With ws
        'Find the last row
        LastRow = .Cells.Find(What:="*", _
             SearchDirection:=xlPrevious, _
        'Find the last column
        LastCol = .Cells.Find(What:="*", _
             SearchDirection:=xlPrevious, _
    End With
    'Finally, initialize a Range object variable for
    'the last populated row.

Set LastCell = ws.Cells(LastRow, LastCol)
End Function


Call procedure for above (not for a worksheet function call)

Sub ShowLastCell()
    MsgBox LastCell(Sheet1).Address(False, False)
End Sub

Try  MsgBox LastCell(Sheet1).Row

Try  MsgBox LastCell(Sheet1).Column


Check to see if active cell is in range A1:A10.

Sub CheckRange()
    Dim rng As Range

    Set rng = Application.Intersect(ActiveCell, Range("A1:A10"))
    If rng Is Nothing Then
        MsgBox "It is not in the range.", vbInformation
        MsgBox "It's in the range called 'A1:A10'!", vbCritical
    End If
End Sub


Current selected rows or cells in a column.

Sub MyCount()
    Dim myCount As Long
    myCount = Selection.Rows.Count
    MsgBox myCount
End Sub


Number of worksheets in a workbook.

Sub MySheetCount()
    Dim myCount As Long
    myCount = Application.Sheets.Count
    MsgBox myCount
End Sub


Copy and paste a range (A1:A3) to active cell in same worksheet.

Sub CopyRange1()
    Range("A1:A3").Copy Destination:=ActiveCell
End Sub


Copy and paste a range (A1:A3) to active cell from ‘Sheet3’.

Sub CopyRange2()
    Sheets("sheet3").Range("A1:A3").Copy Destination:=ActiveCell
End Sub


Show current active cell position (address) – co-ordinate

Sub MyPosition()
    Dim myRpw, myCol
    myRow = ActiveCell.Row
    myCol = ActiveCell.Column
    MsgBox myRow & "," & myCol
End Sub


Specific Range references

Range(“A1”)                       Cell A1

Range(“A1:E10”)                     Range A1 to E10

[A1]                                Cell A1

[A1:E10]                            Range A1 to E10

ActiveCell.Range(“A2”)              The cell below the active cell

Cell(1)                             Cell A1

Range(Cells(1,1),Cell(10,5))        Range A1 to E10

Range(“A:A”)                        Column A

[A:A]                               Column A

Range(“5:5”)                        Row 5

[5:5]                               Row 5

Sheets(“Sheet1”)                    Sheet called Sheet1

Worksheets(“Sheet1”)                Worksheets called Sheet1

Sheets(2)                           Second worksheet in workbook

Worksheets(3)                       Third worksheet in workbook

Worksheets(“Sheet1”).Range(“A1”)    Cell A1 in Sheet1

[Sheet1].[A1]                       Cell A1 in Sheet1

ActiveSheet.Next                    The sheet after the active sheet

Workbook(“Test”)                    Workbook file called Test.xls



Back to top


Navigation in a worksheet using Offset

Sub MoveDown()
    ActiveCell.Offset(1, 0).Select
End Sub


Sub MoveUp()
    ActiveCell.Offset(-1, 0).Select
End Sub


Sub MoveRight()
    ActiveCell.Offset(0, 1).Select
End Sub


Sub DownLeft()
    ActiveCell.Offset(0, -1).Select
End Sub


Sub LastCellInRange()


Back to top


Read Window documents

Calling sub procedure passing a string argument.

Use the Private keyword, which is local and invisible via Excel application.

Private Sub ReadFiles(Path As String)
    Dim FileName As String

    'Initialize a string variable for the first file
    'in a specified directory. This sets the Dir( )
    'function to that directory.

    Select Case Right(Path, 1)
        Case "\":    FileName = Dir(Path)
        Case Else:   FileName = Dir(Path & "\")
    End Select

    'Loop through the specified directory until the
    'Dir( ) function returns an empty string, indicating
    'there are not any more contents to be evaluated.

    Do While Len(FileName) > 0
        'Print each file name to the immediate (debug) window
        Debug.Print FileName
        'Re-initialize the string variable to the next
        'file in the directory

        FileName = Dir()
End Sub


Call the above in a separate procedure

Sub ListFiles()
    ReadFiles "c:\winnt"
End Sub


Back to top


General function examples

Displays the period quarter.

Function Qtr(dtOrig As Date) As String
    Dim qtrNo As Integer
    Dim sQtr As String

    Select Case Format(dtOrig, "q")
        Case Is = 1
            sQtr = "1st Qtr"
        Case Is = 2
            sQtr = "2nd Qtr"
        Case Is = 3
            sQtr = "3rd Qtr"
        Case Is = 4
            sQtr = "4th Qtr"
        Case Else 'assume 1
            sQtr = "1st Qtr"
    End Select
    Qtr = sQtr
 In a worksheet, enter the  formula: =Qtr(“01/01/2010”)
 Show full path and file name in a worksheet.
Function FileName()
    FileName = Application.Caller.Parent.Parent.FullName
End Function
 In a worksheet, enter the  formula: =FileName()

Return the difference in percentage terms of two values (increase/decrease).

Function PChange(OrigVal As Double, NewVal As Double) As Single
    If OrigVal = 0 Then
        PChange = ""
        PChange = ((NewVal - OrigVal) / Abs(OrigVal))
    End If
End Function

In a worksheet, enter the  formula: =PChange(100,150) = 50%
(0.5 for unformatted)


Gross Price (inc)

Function TotalValue(Qty As Double, UPrice As Double) As Double
    TotalValue = Format((Qty * UPrice * 1.175), "£#,##0.00")
End Function


 Age (simple)
Function Age2(DOB)
    Age2 = Int((Now() - DOB) / 365.25) & " Years old"
End Function


 Age (alternative)
Function Age(DOB)
    If Month(DOB) > Month(Now) Then
        Age = Year(Now) - Year(DOB) - 1
    ElseIf Month(DOB) < Month(Now) Then
        Age = Year(Now) - Year(DOB)
    ElseIf Day(DOB) <= Day(Now) Then
        Age = Year(Now) - Year(DOB)
        Age = Year(Now) - Year(DOB) - 1
    End If
End Function


Returns the cell in range which is underline (single style) or the word “unknown”

Public Function GetUnderlinedCell(CellRef As Range) As String
    Dim c As Integer
    Dim sResult As String
    'Force Running when Recalculating Since Formatting Only
    Application.Volatile True

    'Assume Unknown
    sResult = "Unknown"

    'Loop Thru Each Column and Test for Underline
    For c = 1 To CellRef.Columns.Count
        If CellRef.Columns(c).Font.Underline = xlUnderlineStyleSingle Then
            sResult = CellRef.Columns(c).Value
        End If
    Next c

    'Return Results
    GetUnderlinedCell = sResult
End Function


Visual Basic Functions - Choose (Lookup).

Sub LookupExample()
    Dim strMonth As String
    Dim bytCurMonth As Byte

    bytCurMonth = Month(Date)
    strMonth =
Choose(bytCurMonth, "Jan", "Feb", "Mar", "Apr", _
                  "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    MsgBox "Current month is " & strMonth
End Sub

Also, take a look at the Switch() function using VBA Help.


Back to top


Creates a new word document

Creates a new word document and populates the contents of cell “B1” along with some basic formatting.

You need create a reference to the Word Object Library (8.0/9.0/10.0/11.0) in the VB Editor

Sub CreateMSWordDoc()
    On Error GoTo errorHandler

    Dim wdApp As Word.Application
    Dim myDoc As Word.Document
    Dim mywdRange As Word.Range

    Set wdApp = New Word.Application

    With wdApp
        .Visible = True
        .WindowState = wdWindowStateMaximize
    End With

    Set myDoc = wdApp.Documents.Add
    Set mywdRange = myDoc.Words(1) 'index range?

    With mywdRange
        .Text = Range("B1") & vbNewLine & "This above text is _
                                                 stored in cell 'B1'."
        .Font.Name = "Comic Sans MS"
        .Font.Size = 12
        .Font.ColorIndex = wdGreen
        .Bold = True
    End With

    Set wdApp = Nothing
    Set myDoc = Nothing
    Set mywdRange = Nothing
End Sub


Back to top


Creates an Outlook message

Creates an Outlook message (new) populating the ‘To’, ‘subject’ and ‘Body’ properties with the content stored in cell “A1”.

You need create a reference to the Outlook Object Library
(8.0/9.0/10.0/11.0) in the VB Editor

Sub SendMessage()
    Dim objOL As New Outlook.Application
    Dim objMail As MailItem

    Set objOL = New Outlook.Application
    Set objMail = objOL.CreateItem(olMailItem)

    With objMail
        .To = "name@domain.com"
        .Subject = "Excel VBA to Outlook Message Example"
        .Body = "This is an automated message from Excel. " & _
               vbNewLine & "The content of cell reference 'A1' is: " & _
    End With
    Set objMail = Nothing
    Set objOL = Nothing
End Sub


Back to top



Want to teach yourself Access? Free online guide at About Access Databases

Home | Terms of Use | Privacy Policy | Contact

© copyright 2010 TP Development & Consultancy Ltd, All Rights Reserved.

All trademarks are copyrighted by their respective owners. Please read our terms of use and privacy policy.