VBA Snippets
This extension is most comprehensive repository for VBA Snippets.
Starting from basic code snippets (If/Else,For Each,etc.) to entire code snippets useful in your daily work routine.
Originally forked from spences10's repository.

You can contact me in the following ways:
Table of contents
Installation
Launch VS Code Quick Open (Ctrl+P), paste the following command, and press enter.
ext install vba-fullcodesnippets
Overview
abbreviation |
description |
screeon |
Enable Screen Updating option |
screenof |
Disabele Screen Updating option |
lr |
Last row of first column of ActiveSheet |
lc |
Last column of first row of ActiveSheet |
mail |
Mail code block |
#toletter |
Public Function to convert numbers to letter useful for column |
letterto# |
Public Function to convert letter to numbers |
user |
Retrieve Environment Username |
curpath |
Retrieve ActiveWorkbook path |
cltoarray |
Create a variant array with column values |
openword |
Open Word istance |
openwordfile |
Open a Word file |
openurl |
Open a URL |
splitsheet |
Split the current sheet based on column values |
attachthis |
Attach current file to a new mail |
fitcolumns |
AutoFit Columns |
fitrows |
AutoFit Rows |
copysheet |
Copy Active Worksheets into a new Workbook |
refreshpivots |
Refresh all Pivot Tables in ActiveWorkbook |
delrows |
Deleting rows based on conditions |
SelectCase |
SelectCase code block |
Sub |
Sub Code block |
Function |
Private Function code block |
With |
With Code Block |
lastfile |
Retrieve last file ( based on change datetime in a folder) |
Basic Snippets
- Dim declarations
- If/else
- For/While
- Sub/Function with errHandler
- Select Case
- etc.
Dim Declarations Dim
Dim arr()
Dim bol As Boolean
Dim lng As Long
Dim dbl As Double
Dim str As String
Dim obj As Object
Private
If If
If condition Then
End If
Else Else
If condition Then
Else
End If
ElseIf ElseIf
ElseIf condition2 Then
With code block With
With
End With
For Next Loop code block for
For i = lower To upper
Next i
For Each Loop code block ForEach
For Each variable In collection
Next variable
Do Loop While code block DoLoopWhile
Do
Loop While condition
DoWhile code block DoWhile
Do While condition
Loop
While Wend code block While
While condition
Wend
Sub code block Sub
Private Sub func()
'
End Sub
Private Function code block Function
Private Function func(input)
'
End Function
SelectCase code block SelectCase
Select Case test
Case lists
statements
Case Else
elseStatement
End Select
Short Snippets
UBound
LBound
To
Fix
Int
ReDim
Set
Call
Split
Preserve
Option Explicit
On Error Resume Next
ClearContents
Clear
Columns
Rows
CreateObject
IsEmpty
Advanced Snippets
Some useful entire snippets such as opening a Word file, splitting a worksheet..
Enabling Screen Updating screenon
With Application
.ScreenUpdating = True
End With
Disabling Screen Updating screenoff
With Application
.ScreenUpdating = False
End With
Last row on the first column lr
Dim lr as Long: lr= ActiveWorkbook.ActiveSheet.Cells(Rows.Count,\"A\").End(xlUp).Row
Last column on the first row lc
Dim lc as Long: lc= ActiveWorkbook.ActiveSheet.Cells(1,Columns.Count).End(xlToLeft).Column
Mail code block mail
Dim OutApp as Object,OutMail as Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.Subject = ""
.CC = ""
.Body = ""
.Attachments.Add 'Here paste the filepath
.Display '.Send to send the mail
End With
Set OutApp = Nothing
Set OutMail = Nothing
Public Function to convert numbers to letter (useful for column) #toletter
Public Function NumberToLetter(Number As Long) As String
NumberToLetter = Split(Cells(1, Number).Address(True, False),"$")(0)
End Function
Public Function to convert letter to numbersletterto#
Public Function LetterToNumber(Letter as String) As Long
LetterToNumber = Range(Letter & 1).Column
End Function
Retrieve Environment Usernameuser
Environ("Username")
Retrieve ActiveWorkbook Pathcurpath
ActiveWorkbook.Path
Create a variant array with column valuescltoarray
Dim myArr() as Variant,i as Long
Dim col as String: col="A" ' Define here which column take
Dim start as Long: start=1 ' Here set start=2 if you have headers
Dim lr as Long: lr = ActiveWorkbook.ActiveSheet.Cells(Rows.Count,col).End(xlUp).Row
ReDim myArr(start to lr)
For i=start to lr ' If you have header on your Worksheet set i=2
myArr(i) = ActiveWorkbook.ActiveSheet.Cells(i,col).Value
Next i
'Debug.Print Join(myArr,",") 'Transposing array
Open Word Istance openword
Dim WordApp as Object
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.Documents.Add
Open Word File openwordfile
Dim WordApp as Object,WordDoc as Object
Dim filePath as String: filepath= "C:\Desktop\MyDocument.docx" ' Here insert the filepath
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Open(filePath)
Open URL openurl
Dim url as String: url= "https://www.google.com"
ActiveWorkbook.FollowHyperlink Address:= url,NewWindow:=True
Split the current sheet based on column values splitsheet
Dim lr as Long,lc as String,key as Variant
Dim col as String: col="A" 'Here insert column letter for filtering
Set Unique = CreateObject("Scripting.Dictionary")
With ActiveWorkbook.ActiveSheet
lr = .Cells(Rows.Count,col).End(xlUp).Row
lc = NumberToLetter(.Cells(1,Columns.Count).End(xlToLeft).Column)
Set Data = .Range(col & "1:" & col & lr)
On Error Resume Next
For x=2 to lr
Unique.Add Data(x,1).Value,1
Next x
On Error GoTo 0
For Each key In Unique.Keys
.Range(col & "1:" & col & lr).AutoFilter, Field:=.Range(col & 1).Column,Criteria1:=key,Operator:=xlFilterValues
LRFilt = .Range(col & Rows.Count).End(xlUp).Row
.Range(col & "1:" & lc & LRfilt).SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(ActiveSheet.name)).name = key
ActiveSheet.Paste
Cells.EntireColumn.AutoFit
Next key
End With
Attach current file to a new mail attachthis
Application.Dialogs(xlDialogSendMail).Show
AutoFit Columns fitcolumns
Cells.Select
Cells.EntireColumn.AutoFit
AutoFit Rows fitrows
Cells.Select
Cells.EntireRow.AutoFit
Copy Active Worksheets into a new Workbook copysheet
ThisWorkbook.ActiveSheet.Copy Before:=Workbooks.Add.Worksheets(1)
Refresh all Pivot Tables refreshpivots
Dim pt As PivotTable
For Each pt In ActiveWorkbook.PivotTables
pt.RefreshTable
Next pt
Deleting rows based on conditions delrows
With ActiveWorkbook.ActiveSheet
Dim lr as Long: lr = .Cells(Rows.Count,1).End(xlUp).Row
' Delete rows based on rules
For i = lr To 2 Step -1
If Then 'here you need to define rules for deleting rows [e.g. InStr(.Cells(i,2).Value,"Discriminator") ]
Rows(i & ":" & i).EntireRow.Delete
End If
Next i
End With