Menu

Other links

Example code snippets

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
    myDoc.Unprotect
    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
       Else
            cel.Locked = True
            cel.Font.ColorIndex = xlColorIndexAutomatic
       End If
    Next
    myDoc.Protect
    Exit Sub

errorHandler:
     MsgBox "Error"
End Sub

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

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"
            Else
                Cells(rowIndex, colIndex).Value = "X"
            End If
        Next colIndex
    Next rowIndex
End Sub

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.

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
    Next
    Exit Sub
errorHandler:

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
    Next
End Sub

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
    Next
    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.

InputBox and Message Box examples

Sub CalcPay()
    On Error GoTo HandleError

    Dim hours
    Dim hourlyPay
    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)"
    ActiveCell.Range("A1:B1").Select
    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

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()
    Range("HVIII_3A2").PrintOut
    Range("BVIII_3").PrintOut
    Range("BVIII_4A").PrintOut
    Range("HVIII_4A2").PrintOut
    Range("BVIII_5A").PrintOut
    Range("BVIII_5B2").PrintOut
    Range("HVIII_5A2").PrintOut
    Range("HVIII_5B2").PrintOut
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")
        .PageSetup
        .CenterHorizontally = True
        .PrintArea = "$A$3:$F$15"
        .PrintTitleRows = ("$A$1:$A$2")
        .Orientation = xlPortrait
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Worksheets("Sheet1").PrintOut
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")
    ActiveWindow.SelectedSheets.PrintPreview
End Sub

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

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])

Other functions - AVERAGE, MIN, MAX, COUNT, COUNTBLANK, COUNTA, VLOOUKP etc…

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.

Cursors

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
End With

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

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()
Range("A11:D15").Select
Selection.Offset(1, 1).Activate
End Sub

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:="=" & _
Selection.Address()
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
        rName.Delete
    Next rName
End Sub

Scrolls the spreadsheet to where the active cell is.

Sub ScreeTopLeft()
    ActiveCell.Select
    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, _
             SearchOrder:=xlByRows).Row
        'Find the last column
        LastCol = .Cells.Find(What:="*", _
             SearchDirection:=xlPrevious, _
             SearchOrder:=xlByColumns).Column
    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
    Else
        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

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()
Range(ActiveCell.Address).End(xlDown).Select
Range(ActiveCell.Address).End(xlToRight).Select
End Sub

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()
    Loop
End Sub

Call the above in a separate procedure

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

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
End Function

 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 = ""
    Else
        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)
    Else
        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.

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

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

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: " & _
                                                     Range("A1").Value
        .Display
    End With

    Set objMail = Nothing
    Set objOL = Nothing
End Sub

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