Learning how to use Visual Basic for Applications code (VBA) or Macros in Excel, can significantly make your Excel life easier by speeding up your work and saving you a lot of time by allowing the Excel do the work for you rather than you working for it.
Within the following you will find some useful bits of VBA code that we have used on many and varied projects.
This knowledge base of code has been created, developed, or gathered over a long period of time from many varied sources and locations. We list it here so we have a useful collection of VBA macro code modules in a handy location if and when we need to use it.
Please feel free to copy and modify anything we have listed here for your own personal use.
We will keep updating this knowledge with more VBA code macro examples when we come across them. If you think something should be added to this knowledge base, please let us know.
Selecting Cells
Select a cell
Select a cell within the current active worksheet.
Sub SelectACell()
'Description: Select a cell within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("C5").Select
End Sub
Select a cell range
Select a cell range within the current active worksheet.
Sub SelectACellRange()
'Description: Select a cell range within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("C5:C10").Select
End Sub
Select multiple cell ranges
Select multiple cell range within the current active worksheet.
Sub SelectACellRange()
'Description: Select a cell range within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("C5:C10, E2:G2").Select
End Sub
Select the left most cell
Select the left most cell in the current row.
Nb: there should be no "gaps" (or blanks) in your data in order for this to function correctly.
Sub SelectLeftMost()
'Description: Select the left most cell in the current row
'Url: http://www.excelsupersite.com/vba
Range("X1").Select
Selection.End(xlToLeft).Select
End Sub
Select the right most cell
Select the right most cell in the current row.
Nb: there should be no "gaps" (or blanks) in your data in order for this to function correctly.
Sub SelectRightMost()
'Description: Select the right most cell in the current row
'Url: http://www.excelsupersite.com/vba
Range("A1").Select
Selection.End(xlToRight).Select
End Sub
Find the last row of a cell range
Find the last row of data within a range within the current active worksheet.
Option 1 - using the Find function
Sub FindLastRow()
'Description: find the last row number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim lngLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
lngLastRow = ws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
MsgBox "Last row = " & lngLastRow, vbOKOnly, "ExcelSuperSite-KB-Find Last Row"
End Sub
Option 2 - using SpecialCells
Sub FindLastRow()
'Description: find the last row number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim lngLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
lngLastRow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
MsgBox "Last row = " & lngLastRow, vbOKOnly, "ExcelSuperSite-KB-Find Last Row"
End Sub
Option 3 - using Ctrl + Shift + End
Sub FindLastRow()
'Description: find the last row number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim lngLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
lngLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
MsgBox "Last row = " & lngLastRow, vbOKOnly, "ExcelSuperSite-KB-Find Last Row"
End Sub
Option 4 - using Ctrl + Shift + Down (arrow)
Sub FindLastRow()
'Description: find the last row number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim lngLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
lngLastRow = ws.Range("A1").CurrentRegion.Rows.Count
MsgBox "Last row = " & lngLastRow, vbOKOnly, "ExcelSuperSite-KB-Find Last Row"
End Sub
Option 5 - using Named Range
Sub FindLastRow()
'Description: find the last row number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim lngLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
lngLastRow = ws.Range("MyNamedRange").Rows.Count
MsgBox "Last row = " & lngLastRow, vbOKOnly, "ExcelSuperSite-KB-Find Last Row"
End Sub
Option 6 - using UsedRange
Sub FindLastRow()
'Description: find the last row number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim lngLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
lngLastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
MsgBox "Last row = " & lngLastRow, vbOKOnly, "ExcelSuperSite-KB-Find Last Row"
End Sub
Option 7 - using Table Range
Sub FindLastRow()
'Description: find the last row number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim lngLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
lngLastRow = ws.ListObjects("Table1").Range.Rows.Count
MsgBox "Last row = " & lngLastRow, vbOKOnly, "ExcelSuperSite-KB-Find Last Row"
End Sub
Find the last column of a cell range
Find the last column of data within a range within the current active worksheet.
Option 1 - using Ctrl + Shift + End
Sub FindLastCol()
'Description: find the last column number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb as Workbook
Dim ws As Worksheet
Dim lngLastCol As Long
Set ws = wb.ActiveSheet
lngLastCol = ws.Cells(1, sht.Columns.Count).End(xlToLeft).Column
End Sub
Option 2 - using Ctrl + Shift + Right (arrow)
Sub FindLastCol()
'Description: find the last column number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb as Workbook
Dim ws As Worksheet
Dim lngLastCol As Long
Set ws = wb.ActiveSheet
lngLastCol = ws.Range("A1").CurrentRegion.Columns.Count
End Sub
Option 3 - using UsedRange
Sub FindLastCOl()
'Description: find the last column number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb as Workbook
Dim ws As Worksheet
Dim lngLastCol As Long
Set ws = wb.ActiveSheet
ws.UsedRange
lngLastCol = ws.UsedRange.Columns(sht.UsedRange.Columns.Count).Column
End Sub
Option 4 - using Table Range
Sub FindLastCol()
'Description: find the last column number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb as Workbook
Dim ws As Worksheet
Dim lngLastCol As Long
Set ws = wb.ActiveSheet
lngLastCol = ws.ListObjects("Table1").Range.Columns.Count
End Sub
Option 5 - using Named Range
Sub FindLastCol()
'Description: find the last column number of a range
'Url: http://www.excelsupersite.com/vba
Dim wb as Workbook
Dim ws As Worksheet
Dim lngLastCol As Long
Set ws = wb.ActiveSheet
lngLastCol = ws.Range("MyNamedRange").Columns.Count
End Sub
Loop through visible cells
Loop through all visible cells within the current active worksheet.
Sub LoopVisibleCells()
'Description: Loop through all visible cells within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Dim rng As Range
Set rng = Range("A2", Range("A100").End(xlUp)).SpecialCells(xlCellTypeVisible)
For Each cell In rng
' Your Code Goes Here
Next cell
End Sub
Inserting Data
Insert a value into a cell
Insert a value into a cell within the current active worksheet.
Sub InsertValue()
'Description: Insert a value into a cell range within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("D6").value = 7
End Sub
Insert a value into a range of cells
Insert a value into a range of cells within the current active worksheet.
Sub InsertValueCellRange()
'Description: Insert a value into a cell range within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("D6:D12").value = 14
End Sub
Insert a value into cells in multiple ranges
Insert a value into cells of multiple ranges within the current active worksheet.
Sub InsertValue()
'Description: Insert a value into a cell range within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("A7:A10, D6:D12, F3:H3").value = 21
End Sub
Copy and Paste
Copy and Paste data
Copy and Paste data from one cell to another within the current active worksheet.
Option 1
Sub CopyPaste()
'Description: Copy and Paste data from one cell to another within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("A5").Copy
Range("B6").Select
Activesheet.Paste
End Sub
Option 2
Sub CopyPaste()
'Description: Copy and Paste data from one cell to another within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("A5").Copy Destination:=Range("B6")
End Sub
Copy and PasteSpecial Values
Copy and Paste special Values from one cell to another within the current active worksheet.
Option 1
Sub CopyPasteValues()
'Description: Copy and PasteSpecial values from one cell to another within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("A5").Copy
Range("B6").PasteSpecial Paste:=xlPasteValues
End Sub
Option 2
Sub CopyPaste()
'Description: Copy and Paste data from one cell to another within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Range("A5").Copy
Range("B6").Select
Activesheet.Paste
With Range("B6")
.value = .value
End With
End Sub
Copy data from one worksheet to another worksheet
Copy and Paste data from one cell in one worksheet to another cell in another worksheet.
Sub CopyDataWorksheet()
'Description: Copy and Paste data from one cell in one worksheet to another cell in another worksheet.
'Url: http://www.excelsupersite.com/vba
Sheets("Sheet1").Range("A10").Copy
Sheets("Sheet2").Select
Range("B10").Select
Activesheet.Paste
End Sub
Convert to values
Convert any formulas in the specified range of cells (A1 to A10 in this example) into values.
Sub ConvertToValues()
'Description: convert all formulas in the identified range to values
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
With ws.Range("A1:A10")
.Value = .Value
End With
End Sub
Clear Cell data
Clear contents
Clear the contents of a cell but NOT the formatting of the cell.
Sub ClearCellContentsNotFormatting()
'Description: Clear the contents of a cell but NOT the formatting.
'Url: http://www.excelsupersite.com/vba
Range("B10").ClearContents
End Sub
Clear formats and cell contents
Clear the contents and cell formatting of a cell.
Sub ClearCellContents()
'Description: Clear the contents of a cell but NOT the formatting.
'Url: http://www.excelsupersite.com/vba
Range("B10").Clear
End Sub
Worksheets
Un-hide all worksheets
Use a For loop to "loop" through each worksheet in the current active workbook and changes the visible property of each worksheet to visible.
Sub UnhideAllWorksheets()
'Description: un-hide all worksheets within the current active workbook
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub
Hide all worksheets - except the current active worksheet
Use a For loop to "loop" through each worksheet in the current active workbook and changes the visible property of each worksheet, except the current active worksheet, to hidden.
Sub HideAllExceptActiveSheet()
'Description: hide all worksheets within the current active workbook except the active worksheet
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.Visible = xlSheetHidden
End If
Next ws
End Sub
Protect all worksheets
Uses a For loop to "loop" through each worksheet in the current active workbook and adds a password to protect each worksheet.
Sub ProtectAllSheets()
'Description: protect all worksheets within the current active workbook
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim strPassword As String
Set wb = ThisWorkbook
strPassword = "myPassword" 'replace the text myPassword with the password of your choice
For Each ws In wb.Worksheets
ws.Protect password:=password
Next ws
End Sub
Un-protect all worksheets
Uses a For loop to "loop" through each worksheet in the current active workbook and removes the password to un-protect each worksheet.
Sub UnprotectAllSheets()
'Description: un-protect all the worksheets within the current active workbook
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim password As String
Set sb = ThisWorkbook
password = "myPassword" 'replace the text myPassword with the password of your choice
For Each ws In wb.Worksheets
ws.Unprotect password:=password
Next ws
End Sub
Worksheet_Change
Run VBA code whenever a change event occurs on your worksheet i.e. a cell value changes, a user enters data etc.
Private Sub Worksheet_Change(ByVal Target As Range)
'Description: run VBA code whenever a change event occurs on your worksheet
'Url: http://www.excelsupersite.com/vba
'Do nothing if more than one cell is changed or content deleted
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
'onChange for a range of cells
'If Not Intersect(Target, Range("B12:J10000")) Is Nothing Then
'code here
'End If
'onChange for a single cell
If Target.Address = "$A$1" Then
'Turn off events so your code does not put the code into a loop.
Application.EnableEvents = False
Range("A2").Value = Range("A1").Value * 2
'Turn events back on
Application.EnableEvents = True
End If
End Sub
Check if worksheet exists
Check if the worksheet exists before running any code with it.
Function worksheetExists(strWsName As String) As Boolean
'Description: Check if the worksheet exists before running any code with it
'Url: http://www.excelsupersite.com/vba
Dim wb as Workbook
Dim ws as Worksheet
Set wb = Thisworkbook
Set ws = wb.Activesheet
worksheetExists = False
For Each ws In Worksheets
If strWsName = ws.Name Then
worksheetexists = True
Exit For
End If
Next ws
If worksheetexists = False Then
MsgBox "Error: Worksheet <" & strWsName & "> not found"
End If
End Function
Refresh Pivot Tables
Refresh all pivot tables within the current worksheet
Refresh all Pivot Tables within the current active Worksheet.
Sub RefreshAllPivotTables()
'Description: refresh all Pivot Tables within the current Worksheet
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim PT As PivotTable
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
For Each PT In ws.PivotTables
PT.RefreshTable
Next PT
End Sub
VBA Message Box
Message box
Display a message box within your workbook.
Option 1 - Simple message box
Sub MessageBox()
'Description: display a message box
'Url: http://www.excelsupersite.com/vba
MsgBox "I love www.ExcelSuperSite.com"
End Sub
Option 2 - Message box with Title and OK-Cancel buttons
Sub MessageBox()
'Description: display a message box with Title and OK & Cancel buttons
'Url: http://www.excelsupersite.com/vba
MsgBox "I love www.ExcelSuperSite.com", vbOKCancel, "ExcelSuperSite"
End Sub
Option 3 - Pass a value to a message box
Sub MessageBox()
'Description: display a message box with Title and OK & Cancel buttons
'Url: http://www.excelsupersite.com/vba
MsgBox "I love www.ExcelSuperSite.com" & Range("B3").value
End Sub
Conditional Statement
IF THEN ELSE
IF (test criteria)
THEN (if test is true)
ELSE (if test is false)
Sub IfThenElse()
'Description: IF THEN ELSE conditional statement
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
If ws.Range("A1").Value > 50 Then
ws.Range("A2").Value = "Pass"
ElseIf ws.Range("A1").Value > 40 Then
ws.Range("A2").Value = "Conceded Pass"
Else
ws.Range("A2").Value = "Fail"
End If
End Sub
Case Statement
Select Case
Conditional VBA code.
Branch the code depending on the value of your base criteria.
Sub SelectCase()
'Description: Select Case conditional statement
'Url: http://www.excelsupersite.com/vba
Dim wb As Workbook
Dim ws As Worksheet
Dim intCaseTest as Integer
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
intCaseTest = ws.Range("A1").Value
Select Case intCaseTest
Case is > 50
ws.Range("A2").Value = "Pass"
Case is > 40
ws.Range("A2").Value = "Conceded Pass"
Case Else
ws.Range("A2").Value = "Fail"
End Select
End Sub
Workbook Properties
Workbook Properties
Modify the properties of the workbook.
Sub WorkbookProperties()
'Description: Modify the properties of the workbook
'Url: http://www.excelsupersite.com/vba
Dim wb as workbook
Dim ws as worksheet
Dim strmyAuthorOrig As String
Dim strKeywordOrig As String
Dim strTitleOrig As String
Dim strmyTitle As String
Dim strmySubject As String
Dim strmyAuthor As String
Dim strmyManager As String
Dim strmyCompany As String
Dim strmyComments As String
Dim strmyKeywords As String
Dim i As Integer
Set wb = thisworkbook
Set ws = wb.Activesheet
'Setup the values for the properties of the workbook
strmyAuthorOrig = wb.BuiltinDocumentProperties("Author")
strKeywordOrig = wb.BuiltinDocumentProperties("Keywords")
strTitleOrig = wb.BuiltinDocumentProperties("Title")
strmyTitle = "ExcelSuperSite Spreadsheet"
strmySubject = "ExcelSuperSite Spreadsheet"
strmyAuthor = "ExcelSuperSite; www.excelsupersite.com; "
strmyManager = "ExcelSuperSite"
strmyCompany = "ExcelSuperSite"
strmyComments = "This file created by " & strmyAuthor & " for the ExcelSuperSite community on: "
strmyKeywords = "ExcelSuperSite; www.excelsupersite.com; "
With wb
'Clear any previous values
On Error Resume Next
For i = 1 To .BuiltinDocumentProperties.Count
.BuiltinDocumentProperties(i).value = ""
Next
On Error GoTo 0
'Apply above variables
.BuiltinDocumentProperties("Title") = strmyTitle & strTitleOrig
.BuiltinDocumentProperties("Subject") = strmySubject
.BuiltinDocumentProperties("Author") = strmyAuthor & strmyAuthorOrig
.BuiltinDocumentProperties("Manager") = strmyManager
.BuiltinDocumentProperties("Company") = strmyCompany
.BuiltinDocumentProperties("Comments") = strmyComments & Format(Date, "dd-mmm-yyyy")
.BuiltinDocumentProperties("Keywords") = strmyKeywords & strKeywordOrig
End With
MsgBox "Document properties have been updated."
End Sub
Worksheet Objects
Delete all objects
Delete all objects within the current active worksheet.
Sub DeleteObjects()
'Description: Delete all objects within the current active worksheet
'Url: http://www.excelsupersite.com/vba
Dim wb as workbook
Dim ws as worksheet
Dim shp as Shape
Set wb = thisworkbook
Set ws = wb.Activesheet
For Each shp in ws.Shapes
shp.Delete
Next shp
End Sub
Catching VBA Errors
Catch VBA Errors
Catch VBA errors if they occur when your code runs.
Sub CatchErrors()
'Description: Catch VBA errors if they occur when your code runs
'Url: http://www.excelsupersite.com/vba
On Error GoTo errHandler
'----
'your code goes here
'----
exitHandler:
Exit Sub
errHandler:
MsgBox Err.Description, vbOKOnly , "ExcelSuperSite"
Resume exitHandler
End Sub
Print worksheet to PDF
Print to PDF
Print the current active worksheet to a PDF document with the current date and time in the filename.
Sub Print2PDF()
'Description: Print the current active worksheet to a PDF document with the current date and time in the filename
'Url: http://www.excelsupersite.com/vba
Dim wbActive As Workbook
Dim wsActive As Worksheet
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim strTime As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbActive = ActiveWorkbook
Set wsActive = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbActive.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsActive.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for saving file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'user can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to save to PDF")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsActive.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile, vbOKOnly, "ExcelSuperSite - Print to PDF"
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file", vbOKOnly + vbCritical, "ExcelSuperSite - Error"
Resume exitHandler
End Sub