Useful Macro Codes Examples

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 to help you become more productive in your day to day work. 

You can use these macro codes even if you haven't used VBA before that. All you have to do just paste these useful macros 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.

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

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

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

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

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

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

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

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

9. remove spaces from selected cells

One of the most useful macros from this list. It will check your selection and then remove 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

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

11. hide all pivot table subtotals

After creating a pivot table, 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

12. refresh all pivot tables

A super quick method to refresh 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

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

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

Open VBE (ALT + F11).
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.
Paste the code into it & Select the “BeforeDoubleClick” from event drop down menu.
Close VBE & 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

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

16. 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 list the name of all 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

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

​

It 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

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

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

20. insert a linked picture

Insert a live image. 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

21. highlight top 10 values

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

22. 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 last number for serial numbers

After that, it will instantly insert serial numbers starting from the active cell.
Sub AddSerialNumbers()
Dim i As Integer
On Error GoTo Last
i = InputBox("Enter Value", "Enter Serial Numbers")
For i = 1 To i
ActiveCell.Value = i
ActiveCell.Offset(1, 0).Activate
Next i
Last:
Exit Sub
End Sub

23. insert multiple worksheets

Insert multiple worksheets in a single shot.

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

24. highlight named ranges

Instantly 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

25. highlight greater than values

Instantly 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

26. highlight lower than values

Instantly 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

27. protect worksheet

Protect your worksheet with a single click.

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

28. unprotect worksheet

Unprotect your worksheet with a single click.

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

29. convert text to upper case

Convert selected text into upper case text.

This code will help you to convert your text into upper case text in a click.
Sub ConvertUpperCase()
Dim rng As Range
For Each rng In Selection
rng = UCase(rng)
Next rng
End Sub

30. convert text to lower case

Convert selected text into lower case text.

This code will help you to convert your text into lower case text in a click.
Sub ConvertLowerCase()
Dim rng As Range
For Each rng In Selection
rng = LCase(rng)
Next rng
End Sub

31. insert multiple columns

Quickly 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

32. insert multiple rows

Quickly 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

33. 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 autofit all the columns.
Sub AutoFitColumns()
Cells.Select
Cells.EntireColumn.AutoFit
End Sub

34. auto fit rows

Quickly auto fit all the row in your worksheet.

This macro code will select all the cells in your worksheet and instantly autofit all the row.
Sub AutoFitRows()
Cells.Select
Cells.EntireRow.AutoFit
End Sub

35. remove text wrap

Remove text wrap from entire worksheet.

This code will help you to remove text wrap from all the worksheet in a single click. It will first select all the columns and then remove text wrap.
Sub RemoveWrapText()
Cells.Select Selection.WrapText = False
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
End Sub

36. unmerge cells

Unmerge all the cells.

Select your cells and run this code. It will unmerge all the cells from the selection.
Sub UnmergeCells()
Selection.UnMerge
End Sub

37. change chart type

Convert a chart from one to another.

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

38. paste chart as an image

Create an image of your chart.

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

39. add chart title

Add or change 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

40. reverse text

A simple custom function to 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

41. sort worksheets

Quickly 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

42. add workbook to a mail attachment

Attach your excel file in a mail.

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

43. activate r1c1 reference style

Activate R1C1 without using excel options.

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

44. Activate A1 Reference Style

Activate A1 without using excel options.

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

45. Open Calculator

Open windows calculator.

When you run this code it will open window calculator which you can use for your calculations.
Sub OpenCalculator()
Application.ActivateMicrosoftApp Index:=0
End Sub

46. use text to speech

Make excel speak.

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

47. activate user form

User form without any VBA code.

There is a default user 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

48. insert timestamp

Quickly insert the time stamp.

With this code, you can insert a time stamp 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

49. create a pivot table

Automate your pivot table.

You can create a pivot table with this code in seconds with this code.
Sub InsertPivotTable()
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long
'Delete Preivous Pivot Table Worksheet & Insert a New Blank Worksheet With Same Name
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("Data")
'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)
'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="SalesPivotTable")
'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="SalesPivotTable")
'Insert Row Fields
With ActiveSheet.PivotTables("SalesPivotTable").PivotFields("Year")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("SalesPivotTable").PivotFields("Month")
.Orientation = xlRowField
.Position = 2
End With
'Insert Column Fields
With ActiveSheet.PivotTables("SalesPivotTable").PivotFields("Zone")
.Orientation = xlColumnField
.Position = 1
End With
'Insert Data Field
With ActiveSheet.PivotTables("SalesPivotTable").PivotFields("Amount")
.Orientation = xlDataField
.Position = 1
.Function = xlSum
.NumberFormat = "#,##0"
.Name = "Revenue "
End With
'Format Pivot Table
ActiveSheet.PivotTables("SalesPivotTable").ShowTableStyleRowStripes = True
ActiveSheet.PivotTables("SalesPivotTable").TableStyle2 = "PivotStyleMedium9"
End Sub

50. update pivot table range

Automatically 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

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

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

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

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

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

56. remove date from date & 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

57. add header/footer date

Use this code to add a date into the header or footer in your worksheet. You can edit this code to simply switch into header and footer.
Sub dateInHeader()
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&D"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
ActiveWindow.View = xlNormalView
End Sub

58. custom header/footer

And, 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 String
myText = InputBox("Enter your text here", "Enter Text")
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = myText
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End Sub

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

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


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

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

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

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

65. relative to an absolute reference

If you want to convert reference of all the formula from relative to absolute then you can use this code. Select the range of cells where you have formulas and run this macro.
Sub relToAbs() 
For Each c In Selection 
If c.HasFormula= True Then 
c.Formula= Application.ConvertFormula(c.Formula, _ xlA1, xlA1, xlAbsolute) 
End If 
Next c 
End Sub

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

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

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

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

70. 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 useths 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

71. add a number in all the numbers

Just like multiplying you can also add a number into a set of numbers. Here’s the code.
Sub addNumber() Dim rngAs Range DimiAs Integer i= InputBox("Enter number to multiple", "Input Required") For Each rngIn Selection If WorksheetFunction.IsNumber(rng) Then rng.Value= rng+ i Else End If Nextrng End Sub

72. 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 Dimi As Integer For Each rngIn Selection If WorksheetFunction.IsNumber(rng) Then rng.Value= Sqr(rng) Else End If Nextrng End Sub

73. 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 square 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

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

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

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

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

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

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

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

81. convert Roman numbers into Arabic number

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

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

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

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

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

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

87. highlight all the cells in the 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

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

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

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

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

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

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

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

95. print comments

Use this macro to activate settings to print 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

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

97. print selection

This code will help you print selected range. You dont 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

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

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

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