Top 100 Useful Excel Macro [VBA] Codes Examples

 46 COMMENTS

Macro codes can save you a ton of time. You can automate small as well as heavy tasks with VBA codes.

And, do you know with the help of macros, you can break all the limitations of excel which you think Excel

has?

So, today, I have listed some of the useful codes examples to help you become more productive in your day

to day work.

You can use these codes even if you haven't used VBA before that. All you have to do just paste these codes

in your VBA editor.

These codes will exactly do the same thing which headings are telling you. For your convenience, please

follow these steps to add these codes to your workbook.

Important: This is my Ultimate Code Vault which I update on monthly basis with new codes. It would be

great if you bookmark this page and keep on visiting to new codes every time.

First of all, make sure you have your developer tab on your Excel ribbon to access VB editor.

If you don't have please use these simple steps to activate developer tab.

 Go to your developer tab and click on "Visual Basic".

 On the left side in "Project Window", right click on the name of your workbook and insert a new

module.
 Just paste your codes into the module and close it.

 Now, go to your developer tab and click on the macro button.

 It will show you a window with a list of the macros you have in your file. And, you can run a macro

from that list.

And, now let's explore these codes.

Download Free PDF Copy

Enter your name and email below to get a Free PDF copy directly into your inbox.

Yes, Please Send Me

Quick Navigation

Basic

Formatting

Printing

Worksheet

Workbook

Pivot Table

Charts
Advanced

Formulas

1
Basic

These VBA codes will help you to perform some basic tasks in a flash which you frequently do in your

spreadsheets.

Add Serial Numbers

This macro code will help you to automatically add serial numbers in your excel sheet.

Once you run this macro it will show an input box and you need enter max number. After that, it will insert

numbers in the column in a sequence.

Sub AddSerialNumbers()

Dim i As Integer

On Error GoTo Last

i = InputBox("Enter Value", "Enter Serial Numbers")

For i = 1 To iActiveCell.Value = i

ActiveCell.Offset(1, 0).Activate

Next i

Last:Exit Sub

End Sub

Insert Multiple Columns

Once you run this macro it will show an input box and you need to enter the number of columns you want to

insert.

Sub InsertMultipleColumns()

Dim i As Integer

Dim j As Integer
ActiveCell.EntireColumn.Select

On Error GoTo Last

i = InputBox("Enter number of columns to insert", "Insert Columns")

For j = 1 To i

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightorAbove

Next j

Last:Exit Sub

End Sub

Insert Multiple Rows

Once you run this macro it will show an input box and you need to enter the number of rows you want to

insert.

Sub InsertMultipleRows()

Dim i As Integer

Dim j As Integer

ActiveCell.EntireRow.Select

On Error GoTo Last

i = InputBox("Enter number of columns to insert", "Insert Columns")

For j = 1 To i

Selection.Insert Shift:=xlToDown, CopyOrigin:=xlFormatFromRightorAbove

Next j

Last:Exit Sub

End Sub

Auto Fit Columns

Quickly auto fit all the columns in your worksheet. This macro code will select all the cells in your worksheet

and instantly auto-fit all the columns.

Sub AutoFitColumns()

Cells.Select

Cells.EntireColumn.AutoFit

End Sub

Auto Fit Rows

You can use this code to auto-fit all the rows in a worksheet. When you run this code it will select all the

cells in your worksheet and instantly auto-fit all the row.

Sub AutoFitRows()

Cells.Select

Cells.EntireRow.AutoFit

End Sub

Remove Text Wrap

This code will help you to remove text wrap from the entire worksheet with a single click.

It will first select all the columns and then remove text wrap and auto fit all the rows and columns.

Sub RemoveWrapText()

Cells.Select

Selection.WrapText = False

Cells.EntireRow.AutoFit

Cells.EntireColumn.AutoFit

End Sub

Unmerge Cells

Select your cells and run this code and it will unmerge all the cells from the selection with your loosing data.

Sub UnmergeCells()

Selection.UnMerge

End Sub

Open Calculator

In window there is a specific calculator and by using this macro code you can open that calculator directly

from Excel use for your calculations.

Sub OpenCalculator()

Application.ActivateMicrosoftApp Index:=0

End Sub

Add Header/Footer Date

Use this code to add a date into the header or footer in your worksheet. You can edit this code for switching

from header to footer.

Sub dateInHeader()

With ActiveSheet.PageSetup

.LeftHeader = ""

.CenterHeader = "&D"

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""

End With

ActiveWindow.View = xlNormalView

End Sub

Custom Header/Footer

If you want to insert a custom header then this code is for you. Run this code, enter custom value in the

input box. To change the alignment of header or footer you can edit the code.

Sub customHeader()

Dim myText As Stringmy

Text = InputBox("Enter your text here", "Enter Text")

With ActiveSheet.PageSetup

.LeftHeader = ""

.CenterHeader = myText

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""
End With

End Sub

Show Progress on Status Bar

By using this macro you can show the progress of a macro code on the status bar. This code will add serial

numbers up to 5000 in your sheet and along with it will show progress on the status bar.

Sub progressStatusBar()

Application.StatusBar= "Start Printing the Numbers"

For icntr= 1 To 5000

Cells(icntr, 1) = icntr

Application.StatusBar= " Please wait while printing the numbers " & Round((icntr/ 5000 * 100), 0) & "%"

Next

Application.StatusBar= ""

End Sub

2
Formatting
These VBA codes will help you to format cells and ranges using some specific criteria and conditions.

Highlight Duplicates from Selection

This macro will check each cell of your selection and highlight the duplicate values. You can also change the

color from the code.

Sub HighlightDuplicateValues()

Dim myRange As Range

Dim myCell As Range

Set myRange = Selection

For Each myCell In myRange

If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then

 myCell.Interior.ColorIndex = 36

End If

Next myCell

End Sub

Highlight the Active Row and Column

I really love this macro code whenever I have to analyze a data table. Here are the quick steps to apply this

code.

1. Open VBE (ALT + F11).

2. Go to Project Explorer (Ctrl + R, If hidden). Select your workbook & double click on the name of a
particular worksheet in which you want to activate the macro.

3. Paste the code into it and select the “BeforeDoubleClick” from event drop down menu.

4. Close VBE and you are done.

Remember that, by applying this macro you will not able to edit the cell by double click.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim strRange As String

strRange = Target.Cells.Address & "," & _

Target.Cells.EntireColumn.Address & "," & _

Target.Cells.EntireRow.Address

Range(strRange).Select

End Sub

Highlight Top 10 Values

Just select a range and run this macro and it will highlight top 10 values with the green color.
Sub TopTen()

Selection.FormatConditions.AddTop10

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

With Selection.FormatConditions(1)

.TopBottom = xlTop10Top

.Rank = 10

.Percent = False

End With

With Selection.FormatConditions(1).Font

.Color = -16752384

.TintAndShade = 0

End With

With Selection.FormatConditions(1).Interior

.PatternColorIndex = xlAutomatic

.Color = 13561798

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = False

End Sub

Highlight Named Ranges

If you are not sure about how many named ranges you have in your worksheet then you can use this code

to highlight all of them.

Sub HighlightRanges()
Dim RangeName As Name

Dim HighlightRange As Range

On Error Resume Next

For Each RangeName In ActiveWorkbook.Names

Set HighlightRange = RangeName.RefersToRange

HighlightRange.Interior.ColorIndex = 36

Next RangeName

End Sub

Highlight Greater Than Values

Once you run this code it will ask you for the value from which you want to highlight all greater values.

Sub HighlightGreaterThanValues()

Dim i As Integer

i = InputBox("Enter Greater Than Value", "Enter Value")

Selection.FormatConditions.Delete

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:=i

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

With Selection.FormatConditions(1)

.Font.Color = RGB(0, 0, 0)

.Interior.Color = RGB(31, 218, 154)

End With

End Sub

Highlight Lower Than Values

Once you run this code it will ask you for the value from which you want to highlight all lower values.
Sub HighlightLowerThanValues()

Dim i As Integer

i = InputBox("Enter Lower Than Value", "Enter Value")

Selection.FormatConditions.Delete

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLower, Formula1:=i

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

With Selection.FormatConditions(1)

.Font.Color = RGB(0, 0, 0)

.Interior.Color = RGB(217, 83, 79)

End With

End Sub

Highlight Negative Numbers

Select a range of cells and run this code. It will check each cell from the range and highlight all cells the

where you have a negative number.

Sub highlightNegativeNumbers()

Dim Rng As Range

For Each Rng In Selection

If WorksheetFunction.IsNumber(Rng) Then

If Rng.Value < 0 Then

Rng.Font.Color= -16776961

End If

End If

Next
End Sub

Highlight Specific Text

Suppose you have a large dataset and you want to check for a particular value. For this, you can use this

code. When you run it, you will get an input box to enter the value to search for.

Sub highlightValue()

Dim myStr As String

Dim myRg As Range

Dim myTxt As String

Dim myCell As Range

Dim myChar As String

Dim I As Long

Dim J As Long

On Error Resume Next

If ActiveWindow.RangeSelection.Count> 1 Then

myTxt= ActiveWindow.RangeSelection.AddressLocal

Else

myTxt= ActiveSheet.UsedRange.AddressLocal

End If

LInput: Set myRg= Application.InputBox("please select the data range:", "Selection Required", myTxt, , , , , 8)

If myRg Is Nothing Then

Exit Sub

If myRg.Areas.Count > 1 Then

MsgBox"not support multiple columns" GoToLInput

End If

If myRg.Columns.Count <> 2 Then

MsgBox"the selected range can only contain two columns "

GoTo LInput

End If

For I = 0 To myRg.Rows.Count-1

myStr= myRg.Range("B1").Offset(I, 0).Value

With myRg.Range("A1").Offset(I, 0)

.Font.ColorIndex= 1

For J = 1 To Len(.Text)

Mid(.Text, J, Len(myStr)) = myStrThen

.Characters(J, Len(myStr)).Font.ColorIndex= 3

Next

End With

Next I

End Sub

Highlight Cells with Comments

To highlight all the cells with comments use this macro.

Sub highlightCommentCells()

Selection.SpecialCells(xlCellTypeComments).Select

Selection.Style= "Note"

End Sub

Highlight Alternate Rows In The Selection

By highlighting alternate rows you can make your data easily readable. And for this, you can use below VBA

code. It will simply highlight every alternate row in selected range.

Sub highlightAlternateRows()

Dim rng As Range

For Each rng In Selection.Rows

If rng.RowMod 2 = 1 Then

rng.Style= "20% -Accent1"

rng.Value= rng^ (1 / 3)

Else

End If

Next rng

End Sub

Highlight Cells With Misspelled Words

If you find hard to check all the cells for spelling error then this code is for you. It will check each cell from

the selection and highlight the cell where is a misspelled word.

Sub HighlightMisspelledCells()

Dim rng As Range

For Each rng In ActiveSheet.UsedRange

If Not Application.CheckSpelling(word:=rng.Text) Then

rng.Style= "Bad" End If

Next rng

End Sub

Count/Highlight Cells With Error In Entire Worksheet

To highlight and count all the cells in which you have an error, this code will help you. Just run this code and

it will return a message with the number error cells and highlight all the cells.

Sub highlightErrors()

Dim rng As Range

Dim i As Integer

For Each rng In ActiveSheet.UsedRange

If WorksheetFunction.IsError(rng) Then

i = i + 1 rng.Style = "bad"

End If

Next rng

MsgBox "There are total " & i & " error(s) in this worksheet."

End Sub

Count/Highlight Cells With A Specific In Entire Worksheet

This code will help you to count the cells which have a specific value which you will mention and after that

highlight all those cells.

Sub highlightSpecificValues()

Dim rng As Range

Dim i As Integer

Dim c As Variant

c = InputBox("Enter Value To Highlight")

For Each rng In ActiveSheet.UsedRange

If rng = c Then

rng.Style = "Note"
i = i + 1

End If

Next rng

MsgBox "There are total " & i &" "& c & " in this worksheet."

End Sub

Highlight all the Cells in a Worksheet which are Blank but have an Invisible Space

Sometimes there are some cells which are blank but they have a single space. And, due to this, it’s really

hard to identify them. This code will check all the cell in the worksheet and highlight all the cells which have

a single space.

Sub blankWithSpace()

Dim rng As Range

For Each rng In ActiveSheet.UsedRange

If rng.Value = " " Then

rng.Style = "Note"

End If

Next rng

End Sub

Highlight Max Value In The Range

It will check all the selected cells and highlight the cell with the maximum value.

Sub highlightMaxValue()

Dim rng As Range

For Each rng In Selection

If rng = WorksheetFunction.Max(Selection) Then

rng.Style = "Good"

End If

Next rng

End Sub

Highlight Min Value In The Range

It will check all the selected cells and highlight the cell with the Minimum value.

Sub highlightMinValue()

Dim rng As Range

For Each rng In Selection

If rng = WorksheetFunction.Min(Selection) Then

rng.Style = "Good"

End If

Next rng

End Sub

Highlight Unique Values

This codes will highlight all the cells from the selection which has a unique value.

Sub highlightUniqueValues()

Dim rng As Range

Set rng = Selection

rng.FormatConditions.Delete

Dim uv As UniqueValues
Set uv = rng.FormatConditions.AddUniqueValues

uv.DupeUnique = xlUnique

uv.Interior.Color = vbGreen

End Sub

Highlight Difference In Columns

Using this code you can highlight the difference between two columns (corresponding cells).

Sub columnDifference()

Range("H7:H8,I7:I8").Select

Selection.ColumnDifferences(ActiveCell).Select

Selection.Style= "Bad"

End Sub

Highlight Difference In Rows

And, by using this code you can highlight difference between two row (corresponding cells).

Sub rowDifference()

Range("H7:H8,I7:I8").Select

Selection.RowDifferences(ActiveCell).Select

Selection.Style= "Bad"

End Sub

3
Printing
These macro codes will help you to automate some printing tasks which can further save you a ton of time.

Print Comments

Use this macro to activate settings to print cell comments in the end of the page. Let’s say you have 10

pages to print, after using this code you will get all the comments on 11th last page.

Sub printComments()

With ActiveSheet.PageSetup

.printComments= xlPrintSheetEnd

End With

End Sub

Print Narrow Margin

Use this VBA code to take a print with a narrow margin. When you run this macro it will automatically

change margins to narrow.

Sub printNarrowMargin()

With ActiveSheet.PageSetup

.LeftMargin= Application

.InchesToPoints(0.25)

.RightMargin= Application.InchesToPoints(0.25)

.TopMargin= Application.InchesToPoints(0.75)

.BottomMargin= Application.InchesToPoints(0.75)

.HeaderMargin= Application.InchesToPoints(0.3)

.FooterMargin= Application.InchesToPoints(0.3)

End With

ActiveWindow.SelectedSheets.PrintOutCopies:=1, Collate:=True, IgnorePrintAreas:=False End Sub

Print Selection

This code will help you print selected range. You don't need to go to printing options and set printing range.

Just select a range and run this code.

Sub printSelection()

Selection.PrintOutCopies:=1, Collate:=True

End Sub

Print Custom Pages

Instead of using the setting from print options you can use this code to print custom page range. Let’s say

you want to print pages from 5 to 10. You just need to run this VBA code and enter start page and end

page.

Sub printCustomSelection()

Dim startpageAs Integer

Dim endpageAs Integer

startpage= InputBox("Please Enter Start Page number.", "Enter Value")

If Not WorksheetFunction.IsNumber(startpage) Then

MsgBox"Invalid Start Page number. Please try again.", "Error"

Exit Sub

End If

endpage= InputBox("Please Enter End Page number.", "Enter Value")

If Not WorksheetFunction.IsNumber(endpage) Then

MsgBox"Invalid End Page number. Please try again.", "Error"

Exit Sub

End If
Selection.PrintOutFrom:=startpage, To:=endpage, Copies:=1, Collate:=True

End Sub

4
Worksheet

These macro codes will help you to control and manage worksheets in an easy way and save your a lot of

time.

Hide all but the Active Worksheet

Now, let's say if you want to hide all the worksheets in your workbook other than the active worksheet. This

macro code will do this for you.

Sub HideWorksheet()

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets

If ws.Name <> ThisWorkbook.ActiveSheet.Name Then

ws.Visible = xlSheetHidden

End If

Next ws

End Sub

Unhide all Hidden Worksheets

And, if you want to un-hide all the worksheets which you have hide with previous code, here is the code for

that.

Sub UnhideAllWorksheet()
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

ws.Visible = xlSheetVisible

Next ws

End Sub

Delete all but the Active Worksheet

If you want to delete all the worksheets other than the active sheet, this macro is useful for you. When you

run this macro it will compare the name of the active worksheet with other worksheets and then delete

them.

Sub DeleteWorksheets()

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets

If ws.name <> ThisWorkbook.ActiveSheet.name Then

Application.DisplayAlerts = False

ws.Delete

Application.DisplayAlerts = True

End If

Next ws

End Sub

Protect all Worksheets Instantly

If you want to protect your all worksheets in one go here is a code for you. When you run this macro, you

will get an input box to enter a password. Once you enter your password, click OK. And, make sure to take

care about CAPS.

Sub ProtectAllWorskeets()

Dim ws As Worksheet

Dim ps As String

ps = InputBox("Enter a Password.", vbOKCancel)

For Each ws In ActiveWorkbook.Worksheets

ws.Protect Password:=ps

Next ws

End Sub

Resize All Charts in a Worksheet

Make all chart same in size. This macro code will help you to make all the charts of the same size. You can

change the height and width of charts by changing it in macro code.

Sub Resize_Charts()

Dim i As Integer

For i = 1 To ActiveSheet.ChartObjects.Count

With ActiveSheet.ChartObjects(i)

.Width = 300

.Height = 200

End With

Next i

End Sub

Insert Multiple Worksheets

You can use this code if you want to add multiple worksheets in your workbook in a single shot. When you

run this macro code you will get an input box to enter the total number of sheets you want to enter.
Sub InsertMultipleSheets()

Dim i As Integer

i = InputBox("Enter number of sheets to insert.", "Enter Multiple Sheets")

Sheets.Add After:=ActiveSheet, Count:=i

End Sub

Protect Worksheet

If you want to protect your worksheet you can use this macro code. All you have to do just mention your

password in the code.

Sub ProtectWS()

ActiveSheet.Protect "mypassword", True, True

End Sub

Unprotect Worksheet

If you want to unprotect your worksheet you can use this macro code. All you have to do just mention your

password which you have used while protecting your worksheet.

Sub UnprotectWS()

ActiveSheet.Unprotect "mypassword"

End Sub

Sort Worksheets

This code will help you to sort worksheets in your workbook according to their name.

Sub SortWorksheets()
Dim i As Integer

Dim j As Integer

Dim iAnswer As VbMsgBoxResult

iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _

& "Clicking No will sort in Descending Order", _

vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")

For i = 1 To Sheets.Count

For j = 1 To Sheets.Count - 1

If iAnswer = vbYes Then

If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

ElseIf iAnswer = vbNo Then

If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

End If

Next j

Next i

End Sub

Protect all the Cells With Formulas

To protect cell with formula with a single click you can use this code.

Sub lockCellsWithFormulas()
With ActiveSheet

.Unprotect

.Cells.Locked = False

.Cells.SpecialCells(xlCellTypeFormulas).Locked = True

.Protect AllowDeletingRows:=True

End With

End Sub

Delete all Blank Worksheets

Run this code and it will check all the worksheets in the active workbook. And, delete if a worksheet is

blank.

Sub deleteBlankWorksheets()

Dim Ws As Worksheet

On Error Resume Next

Application.ScreenUpdating= False

Application.DisplayAlerts= False

For Each Ws In Application.Worksheets

If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then

Ws.Delete

End If

Next

Application.ScreenUpdating= True

Application.DisplayAlerts= True

End Sub
Unhide all Rows And Columns

Instead of unhiding rows and columns on by one manually you can use this code to do this in a single go.

Sub UnhideRowsColumns()

Columns.EntireColumn.Hidden = False

Rows.EntireRow.Hidden = False

End Sub

Save Each Worksheet as a Single PDF

This code will simply save all the worksheets in a separate PDF file. You just need to change the folder name

from the code.

Sub SaveWorkshetAsPDF()

Dimws As Worksheet

For Each ws In Worksheetsws.ExportAsFixedFormat xlTypePDF, “ENTER-FOLDER-NAME-HERE" & ws.Name & ".pdf" Nextws

End Sub

Disable Page Breaks

To disable page breaks use this code. It will simply disable page breaks from all the open workbooks.

Sub DisablePageBreaks()

Dim wbAs Workbook

Dim wksAs Worksheet

Application.ScreenUpdating= False

For Each wbIn Application.Workbooks

For Each ShtIn wb.WorksheetsSht.DisplayPageBreaks= False

Next Sht

Next wb

Application.ScreenUpdating= True

End Sub

5
Workbook

These codes will help you to perform workbook level tasks in an easy way and with minimum efforts.

Create a Backup of a Current Workbook

This is one of the most useful macros which can help you to save a backup file of your current workbook. It

will save a backup file in the same directory where your current file is saved. And, it will also add the current

date with the name of the file.

Sub FileBackUp()

ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _

"" & Format(Date, "mm-dd-yy") & " " & _

ThisWorkbook.name

End Sub

Close all Workbooks at Once

Use this macro code to close all open workbooks. This macro code will first check all the workbooks one by

one and close them. If any of the worksheets is not saved, you'll get a message to save it.

Sub CloseAllWorkbooks()

Dim wbs As Workbook

For Each wbs In Workbooks

wbs.Close SaveChanges:=True

Next wb

End Sub

Copy Active Worksheet into a New Workbook

Let's say if you want to copy your active worksheet in a new workbook, just run this macro code and it will

do the same for you. It's a super time saver.

Sub CopyWorksheetToNewWorkbook()

ThisWorkbook.ActiveSheet.Copy _

Before:=Workbooks.Add.Worksheets(1)

End Sub

Active Workbook in an Email

Use this macro code to quickly send your active workbook in an e-mail. You can change the subject, email,

and body text in code. And if you want to send this mail directly, use ".Send" instead of ".Display".

Sub Send_Mail()

Dim OutApp As Object

Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

With OutMail

.to = "Sales@FrontLinePaper.com"

.Subject = "Growth Report"

.Body = "Hello Team, Please find attached Growth Report."

.Attachments.Add ActiveWorkbook.FullName

.display

End With

Set OutMail = Nothing

Set OutApp = Nothing

End Sub

Add Workbook to a Mail Attachment

Once you run this macro it will open your default mail client and attached active workbook with it as an

attachment.

Sub OpenWorkbookAsAttachment()

Application.Dialogs(xlDialogSendMail).Show

End Sub

Welcome Message

You can use auto_open to perform a task on opening a file. All you have to do just name your macro

"auto_open".

Sub auto_open()

MsgBox "Welcome To ExcelChamps & Thanks for downloading this file."

End Sub

Closing Message
You can use close_open to perform a task on opening a file. All you have to do just name your macro

"close_open".

Sub auto_close()

MsgBox "Bye Bye! Don't forget to check other cool stuff on excelchamps.com"

End Sub

Count Open Unsaved Workbooks

Let’s you have 5-10 open workbooks, you can use this code to get the number of workbooks which are not

saved yet.

Sub VisibleWorkbooks()

Dim book As Workbook

Dim i As Integer

For Each book In Workbooks

If book.Saved = False Then

i = i + 1

End If

Next book

MsgBox i

End Sub

6
Pivot Table

These codes will help you to manage and make some changes in pivot tables in a flash.

Hide Pivot Table Subtotals

If you want to hide all the subtotals, just run this code. First of all, make sure to select a cell from your pivot

table and then run this macro.

Sub HideSubtotals()

Dim pt As PivotTable

Dim pf As PivotField

On Error Resume Next

Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.name)

If pt Is Nothing Then

MsgBox "You must place your cursor inside of a PivotTable."

Exit Sub

End If

For Each pf In pt.PivotFields

pf.Subtotals(1) = True

pf.Subtotals(1) = False

Next pf

End Sub

Refresh All Pivot Tables

A super quick method to refresh all pivot tables. Just run this code and all of your pivot tables in your

workbook will be refresh in a single shot.

Sub RefreshAllPivotTables()

Dim ws As Worksheet

Dim pt As PivotTable

For Each ws In ThisWorkbook.Worksheets

For Each pt In ws.PivotTables

pt.RefreshTable

Next pt

Next ws

End Sub

Create a Pivot Table

Follow this step by step guide to create a pivot table using VBA.

Auto Update Pivot Table Range

If you are not using Excel tables then you can use this code to update pivot table range.

Sub UpdatePivotTableRange()

Dim Data_Sheet As Worksheet

Dim Pivot_Sheet As Worksheet

Dim StartPoint As Range

Dim DataRange As Range

Dim PivotName As String

Dim NewRange As String

Dim LastCol As Long

Dim lastRow As Long

'Set Pivot Table & Source Worksheet

Set Data_Sheet = ThisWorkbook.Worksheets("PivotTableData3")

Set Pivot_Sheet = ThisWorkbook.Worksheets("Pivot3")

'Enter in Pivot Table Name

PivotName = "PivotTable2"
'Defining Staring Point & Dynamic Range

Data_Sheet.Activate

Set StartPoint = Data_Sheet.Range("A1")

LastCol = StartPoint.End(xlToRight).Column

DownCell = StartPoint.End(xlDown).Row

Set DataRange = Data_Sheet.Range(StartPoint, Cells(DownCell, LastCol))

NewRange = Data_Sheet.Name & "!" & DataRange.Address(ReferenceStyle:=xlR1C1)

'Change Pivot Table Data Source Range Address

Pivot_Sheet.PivotTables(PivotName). _

ChangePivotCache ActiveWorkbook. _

PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRange)

'Ensure Pivot Table is Refreshed

Pivot_Sheet.PivotTables(PivotName).RefreshTable

'Complete Message

Pivot_Sheet.Activate

MsgBox "Your Pivot Table is now updated."

End Sub

Disable/Enable Get Pivot Data

To disable/enable GetPivotData function you need to use Excel option. But, with this code you can do it in a

single click.

Sub activateGetPivotData()

Application.GenerateGetPivotData = True

End Sub
Sub deactivateGetPivotData()

Application.GenerateGetPivotData = False

End Sub

7
Charts

Use these VBA codes to manage charts in Excel and save your lot of time.

Change Chart Type

This code will help you to convert chart type without using chart options from the tab. All you have to do

just specify to which type you want to convert.

Below code will convert selected chart to a clustered column chart. There are different codes for different

types, you can find all those types from here.

Sub ChangeChartType()

ActiveChart.ChartType = xlColumnClustered

End Sub

Paste Chart as an Image

This code will help you to convert your chart into an image. You just need to select your chart and run this

code.

Sub ConvertChartToPicture()

ActiveChart.ChartArea.Copy

ActiveSheet.Range("A1").Select

ActiveSheet.Pictures.Paste.Select
End Sub

Add Chart Title

First of all, you need to select your chart and the run this code. You will get an input box to enter chart title.

Sub AddChartTitle()

Dim i As Variant

i = InputBox("Please enter your chart title", "Chart Title")

On Error GoTo Last

ActiveChart.SetElement (msoElementChartTitleAboveChart)

ActiveChart.ChartTitle.Text = i

Last:

Exit Sub

End Sub

8
Advanced

Some of the codes which you can use to preform advanced task in your spreadsheets.

Save Selected Range as a PDF

Select a range, run this macro and you will get a PDF file for that selected range. It's really cool.

Sub SaveAsPDF()

Selection.ExportAsFixedFormat Type:=xlTypePDF, OpenAfterPublish:=True

End Sub
Create a Table of Content

Let's say you have more than 100 worksheets in your workbook. And, it's hard to navigate now.Don't worry

this macro code will rescue everything.

When you run this code it will create a new worksheet and create a index of worksheets with a hyperlink to

them.

Sub TableofContent()

Dim i As Long

On Error Resume Next

Application.DisplayAlerts = False

Worksheets("Table of Content").Delete

Application.DisplayAlerts = True

On Error GoTo 0

ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1)

ActiveSheet.Name = "Table of Content"

For i = 1 To Sheets.Count

With ActiveSheet

.Hyperlinks.Add _

Anchor:=ActiveSheet.Cells(i, 1), _

Address:="", _

SubAddress:="'" & Sheets(i).Name & "'!A1", _

ScreenTip:=Sheets(i).Name, _

TextToDisplay:=Sheets(i).Name

End With

Next i
End Sub

Convert Range into an Image

Paste selected range as an image. You just have to select the range and once you run this code it will

automatically insert a picture for that range.

Sub PasteAsPicture()

Application.CutCopyMode = False

Selection.Copy

ActiveSheet.Pictures.Paste.Select

End Sub

Insert a Linked Picture

This VBA code will convert your selected range into a linked picture and you can use that image anywhere

you want.

Sub LinkedPicture()

Selection.Copy

ActiveSheet.Pictures.Paste(Link:=True).Select

End Sub

Use Text to Speech

Just select a range and run this code, excel will speak all the text what you have in that range, cell by cell.

Sub Speak()

Selection.Speak

End Sub
Activate Data Entry Form

There is a default data entry form in Excel which you can use for data entry. And, you can use this code to

activate that user form.

Sub DataForm()

ActiveSheet.ShowDataForm

End Sub

Use Goal Seek

Goal Seek can be super helpful for you to solve complex problems. Learn more about goal seek from here

before you use this code.

Sub GoalSeekVBA()

Dim Target As Long

On Error GoTo Errorhandler

Target = InputBox("Enter the required value", "Enter Value") Worksheets("Goal_Seek").Activate

With ActiveSheet .Range("C7")

.GoalSeek_ Goal:=Target, _

ChangingCell:=Range("C2")

End With

Exit Sub

Errorhandler: MsgBox("Sorry, value is not valid.")

End Sub

VBA Code to Search on Google

Follow this post get the VBA code to search on google directly from Excel.

9
 Formulas

These codes will help you to calculate or get results which often you do with worksheet functions and

formulas.

Convert all Formulas into Values

Simply convert formulas into values. When you run this macro it will quickly change the formulas into

absolute values.

Sub ConvertToValues()

Dim MyRange As Range

Dim MyCell As Range

Select Case MsgBox("You Can't Undo This Action. " & "Save Workbook First?", vbYesNoCancel, "Alert")

Case Is = vbYes

ThisWorkbook.Save

Case Is = vbCancel

Exit Sub

End Select

Set MyRange = Selection

For Each MyCell In MyRange

If MyCell.HasFormula Then

MyCell.Formula = MyCell.Value

End If

Next MyCell

End Sub

Remove Spaces from Selected Cells

One of the most useful macros from this list. It will check your selection and then remove all the extra

spaces from that.

Sub RemoveSpaces()

Dim myRange As Range

Dim myCell As Range

Select Case MsgBox("You Can't Undo This Action. " & "Save Workbook First?", _

vbYesNoCancel, "Alert")

Case Is = vbYesThisWorkbook.Save

Case Is = vbCancel

Exit Sub

End Select

Set myRange = Selection

For Each myCell In myRange

If Not IsEmpty(myCell) Then

myCell = Trim(myCell)

End If

Next myCell

End Sub

Remove Characters from a String

Simply remove characters from the starting of a text string. All you need is to refer to a cell or insert a text

into the function and number of characters to remove from the text string.

t has two arguments "rng" for the text string and "cnt" for the count of characters to remove. For example:

If you want to remove first characters from a cell, you need to enter 1 incnt.
Public Function removeFirstC(rng As String, cnt As Long)

removeFirstC = Right(rng, Len(rng) - cnt)

End Function

Add Insert Degree Symbol in Excel

Let’s say you have a list of numbers in a column and you want to add degree symbol with all of them.

Sub degreeSymbol()

Dim rng As Range

For Each rng In Selection

rng.Select

If ActiveCell <> "" Then

If IsNumeric(ActiveCell.Value) Then

ActiveCell.Value = ActiveCell.Value & "°"

End If

End If

Next

End Sub

Reverse Text

All you have to do just enter "rvrse" function in a cell and refer to the cell in which you have text which you

want to reverse.

Public Function rvrse(ByVal cell As Range) As String

rvrse = VBA.strReverse(cell.Value)

End Function
Activate R1C1 Reference Style

This macro code will help you to activate R1C1 reference style without using Excel options.

Sub ActivateR1C1()

If Application.ReferenceStyle = xlA1 Then

Application.ReferenceStyle = xlR1C1

Else

Application.ReferenceStyle = xlR1C1

End If

End Sub

Activate A1 Reference Style

This macro code will help you to activate A1 reference style without using excel options.

Sub ActivateA1()

If Application.ReferenceStyle = xlR1C1 Then

Application.ReferenceStyle = xlA1

Else

Application.ReferenceStyle = xlA1

End If

End Sub

Insert Timestamp

With this code, you can insert a timestamp in sequence from 00:00 to 23:00

Sub TimeStamp()

Dim i As Integer
For i = 1 To 24

ActiveCell.FormulaR1C1 = i & ":00"

ActiveCell.NumberFormat = "[$-409]h:mm AM/PM;@"

ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select

Next i

End Sub

Convert Date into Day

If you have dates in your worksheet and you want to convert all those dates into days then this code is for

you. Simply select the range of cells and run this macro.

Sub date2day()

Dim tempCell As Range

Selection.Value = Selection.Value

For Each tempCell In Selection

If IsDate(tempCell) = True Then

With tempCell

.Value = Day(tempCell)

.NumberFormat = "0"

End With

End If

Next tempCell

End Sub

Convert Date into Year

This code will convert dates into month years.

Sub date2year()

Dim tempCell As Range

Selection.Value = Selection.Value

For Each tempCell In Selection

If IsDate(tempCell) = True Then

With tempCell

.Value = Year(tempCell)

.NumberFormat = "0"

End With

End If

Next tempCell

End Sub

Remove Time from Date

If you have time with the date and you want to remove it then you can use this code.

Sub removeTime()

Dim Rng As Range

For Each Rng In Selection

If IsDate(Rng) = True Then

Rng.Value = VBA.Int(Rng.Value)

End If

Next

Selection.NumberFormat = "dd-mmm-yy"

End Sub
Remove Date from Date and Time

It will return only time from a date and time value.

Sub removeDate()

Dim Rng As Range

For Each Rng In Selection

If IsDate(Rng) = True Then

Rng.Value = Rng.Value - VBA.Fix(Rng.Value)

End If

NextSelection.NumberFormat = "hh:mm:ss am/pm"

End Sub

Convert to Upper Case

Select the cells and run this code. It will check each and every cell of selected range and then convert it into

upper case text.

Sub convertUpperCase()

Dim Rng As Range

For Each Rng In Selection

If Application.WorksheetFunction.IsText(Rng) Then

Rng.Value = UCase(Rng)

End If

Next

End Sub

Convert to Lower Case

This code will help you to convert selected text into lower case text. Just select a range of cells where you

have text and run this code. If a cell has a number or any value other than text that value will remain same.

Sub convertLowerCase()

Dim Rng As Range

For Each Rng In Selection

If Application.WorksheetFunction.IsText(Rng) Then

Rng.Value= LCase(Rng)

End If

Next

End Sub

Convert to Proper Case

And, this code will convert selected text into the proper case where you have the first letter in capital and

rest in small.

Sub convertProperCase()

Dim Rng As Range

For Each Rng In Selection

If WorksheetFunction.IsText(Rng) Then

Rng.Value= WorksheetFunction.Proper(Rng.Value)

End If

Next

End Sub

Convert to Sentence Case

In text case, you have the first letter of the first word in capital and rest all in words in small for a single

sentence. And, this code will help you convert normal text into sentence case.

Sub convertTextCase()

Dim Rng As Range

For Each Rng In Selection

If WorksheetFunction.IsText(Rng) Then

Rng.Value= UCase(Left(Rng, 1)) & LCase(Right(Rng, Len(Rng) -1))

End If

Next rng

End Sub

Remove a Character from Selection

To remove a particular character from a selected cell you can use this code. It will show you an input box to

enter the character you want to remove.

Sub removeChar()

Dim Rng As Range

Dim rc As String

rc = InputBox("Character(s) to Replace", "Enter Value")

For Each Rng In Selection

Selection.Replace What:=rc, Replacement:=""

Next

End Sub

Word Count from Entire Worksheet

It can help you to count all the words from a worksheet.

Sub Word_Count_Worksheet()

Dim WordCnt As Long

Dim rng As Range

Dim S As String

Dim N As Long

For Each rng In ActiveSheet.UsedRange.Cells

S = Application.WorksheetFunction.Trim(rng.Text)

N = 0

If S <> vbNullString Then

N = Len(S) - Len(Replace(S, " ", "")) + 1

End If

WordCnt = WordCnt + N

Next rng

MsgBox "There are total " & Format(WordCnt, "#,##0") & " words in the active worksheet"

End Sub

Remove the Apostrophe from a Number

If you have numeric data where you have an apostrophe before each number, you run this code to remove

it.

Sub removeApostrophes()

Selection.Value = Selection.Value

End Sub

Remove Decimals from Numbers

This code will simply help you to remove all the decimals from the numbers from the selected range.
Sub removeDecimals()

Dim lnumber As Double

Dim lResult As Long

Dim rng As Range

For Each rng In Selection

rng.Value= Int(rng)

rng.NumberFormat= "0"

Next rng

End Sub

Multiply all the Values by a Number

Let’s you have a list of numbers and you want to multiply all the number with a particular. Just use this

code.

Select that range of cells and run this code. It will first ask you for the number with whom you want to

multiple and then instantly multiply all the numbers with it.

Sub multiplyWithNumber()

Dim rng As Range

Dim c As Integer c = InputBox("Enter number to multiple", "Input Required")

For Each rng In Selection

If WorksheetFunction.IsNumber(rng) Then

rng.Value = rng * c

Else

End If

Next rng
End Sub

Add a Number in all the Numbers

Just like multiplying you can also add a number into a set of numbers.

Sub addNumber()

Dim rngAs Range

DimiAs Integer

i= InputBox("Enter number to multiple", "Input Required")

For Each rng In Selection

If WorksheetFunction.IsNumber(rng) Then

rng.Value= rng+ i

Else

End If

Next rng

End Sub

Calculate the Square Root

To calculate square root without applying a formula you can use this code. it will simply check all the

selected cells and convert numbers to their square root.

Sub getSquareRoot()

Dim rngAs Range

Dim i As Integer

For Each rng In Selection

If WorksheetFunction.IsNumber(rng) Then
rng.Value= Sqr(rng)

Else

End If

Next rng

End Sub

Calculate the Cube Root

To calculate cube root without applying a formula you can use this code. It will simply check all the selected

cells and convert numbers to their cube root.

Sub getCubeRoot()

Dim rng As Range

Dimi As Integer

For Each rng In Selection

If WorksheetFunction.IsNumber(rng) Then

rng.Value = rng ^ (1 / 3)

Else

End If

Nextrng

End Sub

Add A-Z Alphabets in a Range

Just like serial numbers you can also insert alphabets in your worksheet. Beloware the code which you can

use.

Sub addcAlphabets()
Dim i As Integer

For i= 65 To 90

ActiveCell.Value= Chr(i)

ActiveCell.Offset(1, 0).Select

Next i

End Sub

Sub addsAlphabets()

Dim i As Integer

For i= 97 To 122

ActiveCell.Value= Chr(i)

ActiveCell.Offset(1, 0).Select

Next i

End Sub

Convert Roman Numbers into Arabic Numbers

Sometimes it’s really hard to understand Roman numbers as serial numbers. This code will help you to

convert roman numbers into arabic numbers.

Sub convertToNumbers()

Dim rng As Range

Selection.Value= Selection.Value

For Each rng In Selection

If Not WorksheetFunction.IsNonText(rng) Then

rng.Value= WorksheetFunction.Arabic(rng)

End If
Next rng

End Sub

Remove Negative Signs

This code will simply check all the cell in the selection and convert all the negative numbers into positive.

Just select a range and run this code.

Sub removeNegativeSign()

Dim rngAs Range

Selection.Value= Selection.Value

For Each rngIn Selection

If WorksheetFunction.IsNumber(rng)

Then rng.Value= Abs(rng)

End If

Next rng

End Sub

Replace Blank Cells with Zeros

For data where you have blank cells, you can add zeros in all those cells. It makes easier to use formula and

use those cells in further calculations.

Sub replaceBlankWithZero()

Dim rngAs Range

Selection.Value= Selection.Value

For Each rngIn Selection

If rng= "" Or rng= " " Then

 rng.Value= "0"

Else

End If

Next rng

End Sub

Conclusion

I use some of these codes every day to increase my productivity. And, I’m sure it will also help you in your

work.

But, you have to help me to update this list. If you have any useful code which you use in work to save your

time, please share with me in the comment section, I’d love to hear from you.

And, please don’t forget to share this list with your friends.

Share

Tweet

Download Free PDF Copy

Enter your name and email below to get a Free PDF copy directly into your inbox.

Yes, Please Send Me

Must Read Next

1. The Definitive Guide to Write Conditions with VBA IF Statement

2. 8 Simple Steps to Use VBA to Create a Pivot Table In Excel [Macro Code]
3. How to Use VBA MsgBox Function in Excel
4. VBA ON-OFF Button In Excel

DOWNLOAD NOW
 EXCEL PRODUCTIVITY GUIDE
With this guide, you can take your skills to whole next level. It will help you to win at your daily work using some smart tactics.
 30 Useful Excel Tips
 80 Excel Keyboard Shortcuts

 100 VBA Codes

 100 Excel Functions

 4 Specific Excel Templates

“Your excel book is immensely helpful. Thank you for sharing it”

Joseph Gabriella, Japan

Get Instant Access

100% Privacy. I will never spam you!
About | Contact | Free E-Book

© 2017 Excel Champs