Useful Excel Macro VBA
Hi Friends,
Here in this article, I have tried to consolidate some
most useful and more frequently used excel macro with examples. This is part 1
where I have provided 20 Excel Macros related to workbook and worksheets.
Basic
Codes
These VBA codes will help you to perform some basic tasks in a flash
which you frequently do in your spreadsheets.
1. 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 you an input box where you need to
enter max number for the serial numbers and 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 i
ActiveCell.Value = i
ActiveCell.Offset(1, 0).Activate
Next i
Last:Exit Sub
End Sub
2. 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
3. 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
4. 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
5. 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
6. 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
7. Unmerge Cells
Select your cells and run this code and it will un-merge all the cells
from the selection with your loosing data.
Sub UnmergeCells()
Selection.UnMerge
End Sub
8. 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
9. 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
10. 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
Formatting
Codes
These VBA codes will help you to format cells and ranges using some
specific criteria and conditions.
11. 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
12. Highlight the Active Row and
Column
I really love to use 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).
3. Select your
workbook & double click on the name of a particular worksheet in which you
want to activate the macro.
4. Paste the code into
it and select the “BeforeDoubleClick” from event drop down menu.
5. Close VBE and you
are done.
Remember that, by applying this macro you wi ll 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
13. 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).S
tFirstPriority
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
14. 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
15. 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).S
tFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(31, 218, 154)
End With
End Sub
16. 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).S
tFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(217, 83, 79)
End With
End Sub
17. 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
18. Highlight Specific Text
Suppose you have a large data set 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
19. 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
20. 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
21. 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
22. Highlight Cells With Error in the
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
23. Highlight Cells with a Specific
Text in 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
24. Highlight all the Blank Cells
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
25. 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
26. 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
27. 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
28. 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
29. 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
Printing
Codes
These macro codes will help you to automate some printing tasks which
can further save you a ton of time.
30. 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
31. 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
32. 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
33. 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
Worksheet
Codes
These macro codes will help you to control and manage worksheets in an
easy way and save your a lot of time.
34. 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
35. 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
36. 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
37. 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
38. 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
39. 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
40. 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
41. Un-Protect 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
42. 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
43. 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
44. 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
45. 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
46. 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
47. 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
Workbook
Codes
These codes will help you to perform workbook level tasks in an
easy way and with minimum efforts.
48. 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
49. 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
50. 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
51. 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
52. 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
53. Welcome Message
You can use auto_open to perform a task on opening a file and 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
54. Closing Message
You can use close_open to perform a task on opening a file and 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
55. 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
Pivot
Table Codes
These codes will help you to manage and make some changes in pivot
tables in a flash.
56. 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
57. 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 CloseAllWorkbooks()
Dim wbs As Workbook
For Each wbs In Workbooks
wbs.Close SaveChanges:=True
Next wb
End Sub
58. Create a Pivot Table
Follow this step by
step guide to create
a pivot table using VBA.
59. 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
60. 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
Charts
Codes
Use these VBA codes to manage charts in Excel and save your lot of
time.
61. 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.
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
62. 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
63. 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
Advanced
Codes
Some of the codes which you can use to preform advanced task in your
spreadsheets.
64. Save Selected Range as a PDF
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.n ame)
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
65. 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
66. 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
67. 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
68. 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
69. Activate Data Entry Form
There is a default
data entry form which you can use for data entry.
Sub DataForm()
ActiveSheet.ShowDataForm
End Sub
70. 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
71. VBA Code to Search on Google
Follow this post to learn how to use this VBA
code to search on Google.
Sub SearchWindow32()
Dim chromePath As String
Dim search_string As String
Dim query As String
query = InputBox("Enter here your search
here", "Google Search")
search_string = query
search_string = Replace(search_string, "
", "+")
'Uncomment the following line for Windows 64
versions and comment out Windows 32 versions'
chromePath = "C:Program
FilesGoogleChromeApplicationchrome.exe"
'Uncomment the following line for Windows 32
versions and comment out Windows 64 versions
chromePath = "C:Program Files
(x86)GoogleChromeApplicationchrome.exe"
Shell (chromePath & " -url
http://google.com/#q=" & search_string)
End Sub
Formula
Codes
These codes will help you to calculate or get results which often you do
with worksheet functions and formulas.
72. 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
73. 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
74. 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 in cnt.
Public Function removeFirstC(rng As String, cnt As
Long)
removeFirstC = Right(rng, Len(rng) - cnt)
End Function
75. 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
76. 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
77. Activate R1C1 Reference Style
This macro code will help you to activate R1C1
reference style without using Excel options.
Sub DataForm()
ActiveSheet.ShowDataForm
End Sub
78. 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
79. Insert Time Range
With this code, you can insert a time range 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
80. 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
81. Convert Date into Year
This code will convert dates into 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
82. 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
83. 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
84. 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
85. 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
86. 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
87. 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
88. 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
89. 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
90. 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
91. 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
92. 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
93. 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
94. 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
95. 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
96. 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
97. 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
98. 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
99. Replace Blank Cells with Zeros
For data where you have blank cells, you can use the below code to add
zeros in all those cells. It makes easier to 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
100. Excel Macro to Create a new Excel workbook file
Use the
following Excel VBA code to create a new Excel Workbook and save it as a given
path as shown in the below code.
Sub CreateNewExcelWorkbook()
Dim wb As Workbook
Set wb = Workbooks.Add
' now if you want to save this new workbook
' save it by providing the full name of the file
wb.SaveAs "C:\abc\temp.xlsx"
End Sub
102.Excel Macro to open an existing
excel workbook
Refer the
following Excel VBA code to open an existing excel workbook which is saved at a
given path.
To run the below code, do not forget to change the file path which I have provided.
To run the below code, do not forget to change the file path which I have provided.
Sub openExcelWorkbook()
Dim wb As Workbook
Dim fPath As String
fPath = "C:\....\myfile.xlsx"
Set wb = workbooks.Open(Filename:=fPath)
'given workbook is opened and it is referred by
' the variable wb of type workbook
' now you can do all the operations on wb which
' you want to do on this workbook
'For Example to close this workbook
wb.Close
End Sub
Note:
Once you opened your workbook, you
should set it to a variable of Workbook type, so that you can refer this
workbook by this variable wherever you want to use in your program.
103.Excel Macro to close a workbook
with or without saving the changes
It is
logical that after working on your workbook, at the end of the progrma you want
to keep closing the workbook which you VBA program is using. So here is the
example of closing your workbook.
As you know on closing an opened workbook, there are two possibilities:
As you know on closing an opened workbook, there are two possibilities:
1. Close
the workbook without saving all the changes which are not saved yet
2. Close the workbook without saving any of the unsaved changes
2. Close the workbook without saving any of the unsaved changes
It is
very simple to do using Excel VBA. While closing if set the SaveChanges
parameter to true then changes will be saved and if it is set to false
then changes will be ignored. Refer the below code…
Sub closeWorkbook()
Dim wb As Workbook
Dim fPath As String
fPath = "C:\....\myfile.xlsx"
Set wb = workbooks.Open(Filename:=fPath)
' For Example:
' To close this workbook with
' saving the changes
wb.Close SaveChanges:=True
' To close this workbook without
' saving the changes
wb.Close SaveChanges:=False
End Sub
104.Excel Macro to save or saveAs a
workbook
As you
must be aware of the difference between Save and SaveAs. It is same here in
Excel vba as well.
If you want to save the changes in the same file then you can use the Save statement in Excel VBA else SaveAS.
Note: For saveAs you need to provide the complete path[including file name] for the new file where you want to save it.
If you want to save the changes in the same file then you can use the Save statement in Excel VBA else SaveAS.
Note: For saveAs you need to provide the complete path[including file name] for the new file where you want to save it.
Sub saveWorkbook()
Dim wb As Workbook
Dim fPath As String
Dim newPath As String
fPath = "C:\....\myfile.xlsx" ' old path
newPath = "D:\....\myfile1.xlsx" ' new path
Set wb = workbooks.Open(Filename:=fPath)
' To save your workbook at the same
' location with same name
wb.Save
' to save your workbook on a different location
' or with a different name or both
wb.SaveAs Filename:=newPath
End Sub
105.Excel Macro to delete a workbook
You can
use the following example to delete a workbook.
Note: Kill statement is basically used to delete any file using Exel VBA. So you can even delete some word doc, text file etc.
Note: Kill statement is basically used to delete any file using Exel VBA. So you can even delete some word doc, text file etc.
Sub deleteFile()
Dim wb As Workbook
Dim fPath As String
' full path of the file which you want to delete
' this is not necessarily to be excel file
' it can be any file
fPath = "C:\....\myfile.xlsx"
' this statement will delete the file
Kill PathName:=fPath
End Sub
106.Excel Macro to add a new worksheet
in a workbook
So far in
the above examples, you had seen how to deal with Workbook itself like opening,
closing, saving, deleting etc.
Now using the below example you can add a new WorkSheet in a Workbook. To perform any such operations on a workbook, you first need to have a Workbook, therefore you will see that in all the below examples, I have first opened a workbook and assigned that Workbook to a variable wb.
Now using the below example you can add a new WorkSheet in a Workbook. To perform any such operations on a workbook, you first need to have a Workbook, therefore you will see that in all the below examples, I have first opened a workbook and assigned that Workbook to a variable wb.
Sub addNewSheetInAWorkbook()
Dim wb As Workbook
Dim fPath As String
fPath = "C:\....\myfile.xlsx"
Set wb = workbooks.Open(Filename:=fPath)
' Add a new worksheet in your workbook
wb.Worksheets.Add
End Sub
Note:
In the above statement after .add
there is no other parameter specified therefore new sheet will be added before
the activesheet.
107.Excel Macro to add a worksheet at
a specified position
As
mentioned in the above example, if do not provide the position parameter while
adding a new sheet in a workbook, by default it will get added before the
activeSheet.
Now here in the below example, I am showing you – how can you provide the position parameter while adding a new sheet.
Refer the comments… written inside the code.
Now here in the below example, I am showing you – how can you provide the position parameter while adding a new sheet.
Refer the comments… written inside the code.
Sub addNewSheetInAWorkbookAtPosition()
Dim wb As Workbook
Dim fPath As String
fPath = "C:\....\myfile.xlsx"
Set wb = workbooks.Open(Filename:=fPath)
' Add a new worksheet in your workbook
' Below statement will add your new sheet at first position
wb.Worksheets.Add Before:=1
' Below statement will add your new sheet at second position
wb.Worksheets.Add After:=1
' Below statement will add your new sheet at the end
wb.Worksheets.Add After:=Worksheets.Count
End Sub
108.Excel Macro to rename a worksheet
Renaming
is simply done by setting new name of the worksheet to the .Name
property of a worksheet as shown in below code
Sub renameWorksheet()
Dim wb As Workbook
Dim sh As Worksheet
Dim newSheetName As String
newSheetName = "March"
Dim fPath As String
fPath = "C:\Users\vmishra\Desktop\myfile.xlsx"
Set wb = workbooks.Open(Filename:=fPath)
' Rename the sheet name of the 1st sheet
Set sh = wb.Worksheets(1)
sh.Name = newSheetName
End Sub
Comments
Post a Comment