VBA Cheat Sheet
Workbook and Worksheets
Total Number of Rows and Columns : Find First Blank Space Position :
No of Rows: 10,48,576 No of Columns : 16,384 x = VBA.InStr(Sheet1.Range("a3"), " ")
Change the Domain Name of the Sheet :
ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).Properties("_CodeName") = "Summary_Sheet"
Select Multiple Worksheets :
Sheets(Array("Sheet1", "Sheet4", "Sheet5")).Select
Delete Multiple Worksheets : Delete Workbook :
Kill “FilePath\myworkbook.xlsx" ‘ Delete single file
Sheets(Array("Sheet1", "Sheet4", "Sheet5")).Delete
Kill "YourFolderPath\" * .xl * "" ‘ Delete entire excel file from folder
Type of Input Box:
Application.InputBox("Enter number") ‘[ It allow to take cell references ]
VBA.InputBox("Enter number") ‘[ Manually Enter ]
Protect and Unprotect Worksheet :
Sheets("Summary").Protect Password:="abc"
Sheets("Summary").Unprotect Password:="abc"
Display and Not Display :
ActiveWindow.DisplayGridlines = False ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False ActiveWindow.DisplayHorizontalScrollBar = False
Application.DisplayFormulaBar = False ActiveWindow.DisplayVerticalScrollBar = False
Application.DisplayFormulaBar = True Application.DisplayFullScreen = False
Code Name of worksheet : Get Name of last worksheet and workbook:
MsgBox Sheets(Sheets.Count).Name ‘name of last sheet in the workbook
MsgBox Sheets("Summary").CodeName
MsgBox Workbooks(Workbooks.Count).Name ‘ name of last opened workbook
Send Email :
ActiveWorkbook.SendMail Recipients:=Array("abc@gmail.com", "xyz@gmail.com"), Subject:="Welcome", ReturnReceipt:=""
Get Full name and Path of Workbook :
MsgBox ThisWorkbook.FullName [Output—> C:\Users\RAM\desktop\abc.xlsm ]
MsgBox ThisWorkbook.Path [Output—> C:\Users\RAM\desktop ]
Save , SaveAs and Close of Workbook :
ThisWorkbook.Save
ThisWorkbook.SaveAs Filename:=VBA.Environ("UserProfile") & "\desktop\" & "Myworkbook2”
ThisWorkbook.Close SaveChanges:=False
Get File Name from SaveAs dialog box :
FileName = Application.GetSaveAsFilename
Dynamic Range Selection
Sheet1.Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Select ‘ Range Selection
Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column ‘Get last column number
Sheet1.Cells(Rows.Count, 1).End(xlUp).Row ‘ Get last row number
Extract Unique Records using advance filter :
Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[k1], Unique:=True
Text to Column :
Range("A2:a9").TextToColumns Destination:=Range("e2"), DataType:=xlDelimited, Space:=True, _
FieldInfo:=Array(Array(1, 9), Array(2, 1), Array(3, 9))
Loop
Select Case Statements For Loop Do While Loop
Dim chr As String
Example-1: Example-1: Example-2:
chr = InputBox("Enter the char")
For i = 1 To 20 Step 3 Dim i As Integer, sum As Integer Dim i As Integer, total As Integer
Select Case chr
MsgBox i i = 10 i=5
Case "A" To "L"
Next i sum = 0 total = 0
MsgBox "between A and L"
Case "M" To "T" Do While i >= 5 Do
MsgBox "between M and T" Example-2: sum = i + sum total = i + total
Case "U" To "Z" Dim j As Integer i=i-1 i=i-1
MsgBox "between U and Z" For j = 1 To ThisWorkbook.Worksheets.Count Loop Loop While i >= 10
Case Else MsgBox Worksheets(j).Name MsgBox total
MsgBox "Wrong choice" Next j MsgBox sum
End Select
Extract Number: Text in Reverse Order
dim j as Integer
Dim i As Integer, MyName As String, ReverseName As String
For j = 1 To Len(Range(”a1”)) MyName = Sheet1.Range("A2").Value
If VBA.Mid(Range(”a1”), j, 1) Like "[0-9]" Then For i = 0 To VBA.Len(MyName) - 1
Range(”b1”).Value = Range(”b1”).Value & VBA.Mid(Range(”b1”), j, 1) ReverseName = ReverseName & VBA.Mid(MyName, Len(MyName) - i, 1)
End If Next i
Next j MsgBox ReverseName
Do Until Loop For Each Loop
Example-1: Example-2:
Dim i As Integer Dim i As Integer [a1].Select
i=1 i=1 For Each Sheet In ThisWorkbook.Worksheets
Do Do Until i > 10 ActiveCell = Sheet.Name
Cells(I, 1) = 2 * i MsgBox i ActiveCell.Offset(1, 0).Select
i=i+1 i=i+1 Next Sheet
Loop Until i = 11 Loop
First name , Middle name and Last name by VBA
full_name = Sheet3.Range("a2")
arr = VBA.Split(full_name, " ")
first_name = arr(0) 'Return the first element of array
last_name = arr(UBound(arr)) 'Return last element of array
middle_name = VBA.Mid(full_name, VBA.InStr(full_name, " "), VBA.Len(full_name) - VBA.Len(first_name & last_name))
Sheet3.Range("b2") = first_name
Sheet3.Range("c2") = Trim(middle_name)
Sheet3.Range("d2") = last_name
Files and Folders
Add Library Get Special Folder Path
Add References > Microsoft Scripting Runtime Dim fso As New FileSystemObject
or WindowsFldr = fso.GetSpecialFolder(0)
Application.VBE.ActiveVBProject.References.AddFromFile ("C:\Windows\System32\scrrun.dll") SystmFldr = fso.GetSpecialFolder(1)
TempFldr = fso.GetSpecialFolder(2)
Loop on File and Folder File Dialog to select Folder
Dim fso As New FileSystemObject Dim FolderPath As String
Dim myFile As file Dim fso As New FileSystemObject
Dim myFolder As Folder Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Data Folder"
Set myFolder = fso.GetFolder("D:\Users\RAM\Desktop\Airtel\") Application.FileDialog(msoFileDialogFolderPicker).Show
' Open All Excel Files FolderPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
For Each myFile In myFolder.Files MsgBox FolderPath
If fso.GetExtensionName(myFile) = "xlsx" Then
Workbooks.Open myFile
Else
End If
Next myFile
Check File / Folder Exist or Not Open application using VBA
Dim fso As New FileSystemObject
Call Shell("explorer.exe " & FolderPath, vbNormalFocus) ‘ open folder
Dim FolderPath As String
Call Shell("notepad")
FolderPath = "C:\Users\Abhishek\Desktop\Santosh1"
If fso.FolderExists(FolderPath) Then ‘ fso.FileExists(FilePath)
MsgBox "Specified Folder is Exist in the system", vbInformation, "Folder status"
fso.CreateFolder (FolderPath)
Else
MsgBox "Folder Doesn't Exist"
End If
Pivot Table
Dim pTable As PivotTable
Dim pCache As PivotCache
Dim pSheet As Worksheet
Dim pDataRange As Range
Dim pField As PivotField
Set pSheet = Worksheets.Add(Before:=Sheets(1))
pSheet.Name = "Summary"
Set pDataRange = Sheet1.Range("a1").CurrentRegion
Set pCache = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=pDataRange)
Set pTable = pCache.createpivottable(TableDestination:=pSheet.Range("a3"), TableName:="MyPivotTable1")
Set pField = pTable.PivotFields("name")
pField.Orientation = xlRowField
pField.Position = 1
Set pField = pTable.PivotFields("Amount")
pField.Orientation = xlDataField
pField.Function = xlCount
pField.Name = "Total Count"
Set pField = pTable.PivotFields("year")
pField.Orientation = xlPageField
pField.PivotItems("2016").Visible = False ‘ unselect 2016 in pivot filter
' Remove Subtotal
On Error Resume Next
For Each pField In PivTable.PivotFields
pField.Subtotals(1) = False
Next
Outlook Connectivity
Add Library / Create Object
Add References > Microsoft Outlook 15.0 Object Library
or
Set OutlookApp = CreateObject("Outlook.Application")
Set ObjMail = ObjOutlook.CreateItem(olMailItem)
Send Mail via Outlook Send Chart on Outlook Mail Body
Dim Outlook_App As New Outlook.Application Dim Outlook_App As Object
Dim Outlook_Mail As Outlook.MailItem Dim Outlook_Mail As Object
Dim chart_path As String
Set Outlook_App = New Outlook.Application
Set Outlook_Mail = Outlook.CreateItem(olMailItem) chart_path = Environ("userprofile") & "\chart1.gif"
Sheet1.ChartObjects("MyChart").Chart.Export Filename:=chart_path, Filtername:="gif"
With Outlook_Mail
.To = "" Set Outlook_App = CreateObject("Outlook.Application")
.CC = "" Set Outlook_Mail = Outlook_App.CreateItem(0)
.BCC = ""
.Subject = "Welcome" With Outlook_Mail
.HTMLBody = "Dear Sir,<br><br> Greetings for the day. " .to = "abc@gmail.com"
'.Attachments.Add .Subject = "Chart - Summary"
.Display .HTMLBody = "Hi <br> I am sending below chart.<br> <img src= '" & chart_path & "'>"
.Send .display
End With End With
Set Outlook_App = Nothing
Set Outlook_Mail = Nothing Kill chart_path
Set Outlook_App = Nothing
Set Outlook_Mail = Nothing
Chart
Create Chart
Dim Data_Range As Range
Dim ch As Shape
Set Data_Range = Sheet1.Range("a1").CurrentRegion
Set ch = Sheet1.Shapes.AddChart2(Style:=12, XlChartType:=xlColumn, Left:=200, Top:=0, Width:=300, Height:=200)
With ch.Chart
.SetSourceData Data_Range
.ChartTitle.Text = "Product Summary"
.HasLegend = False
.FullSeriesCollection(1).ApplyDataLabels
.FullSeriesCollection(2).ApplyDataLabels
.FullSeriesCollection(2).Points(1).Select
Selection.Format.Fill.ForeColor.RGB = vbYellow
.FullSeriesCollection(2).ChartType = xlLineStacked
.FullSeriesCollection(2).Format.Line.ForeColor.RGB = vbBlue
.Axes(xlValue).MajorGridlines.Delete
End With
Database Connectivity
Add Library / Create Object
Add References > Microsoft ActiveX Data Objects 2.8 Library
or
Set Conn = CreateObject("ADODB.Connection")
Set Record_set = CreateObject("ADODB.Recordset")
Retrieve Data From SQL Server
Dim Conn As New ADODB.Connection
Dim rs As New ADODB.RecordSet
Dim sql_cmd As String
'Open SQL Connection
Conn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Data Source=rk-pc;Initial Catalog=rmg_master"
Conn.Open
'SQL Query
sql_cmd = "select * from client_details"
'Open Record Set
Set rs.ActiveConnection = Conn
rs.Open sql_cmd, Conn
'Header for data
[a1].Select
For Each i In rs.Fields
ActiveCell.Value = i.Name
ActiveCell.Offset(0, 1).Select
Next i
'Copy to Excel
ActiveSheet.Range("a2").CopyFromRecordset rs
rs.Close
Conn.Close
Retrieve Data From MS-Access
Dim conn As Object
Dim rs_data As Object
Set conn = CreateObject("ADODB.Connection")
Set rs_data = CreateObject("ADODB.RecordSet")
'Open MS-Access Connection
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=D:\VBA Interview\Database1.accdb;" & _
"user id=; password="
conn.Open
'Open Record Set
With rs_data
.ActiveConnection = conn
.Source = "Select * from Table1"
.Open
End With
'Table Header
Sheet2.Range("a1").Select
For Each Field In rs_data.Fields
ActiveCell.Value = Field.Name
ActiveCell.Offset(0, 1).Select
Next Field
'Copy Data to Excel
Sheet2.Range("a2").CopyFromRecordset rs_data
