Excel VBA

Click the dropdown to view articles in the Excel VBA section:

If you are looking for Excel VBA code samples, here are some pages that should be useful to you. Click on the links above to access the code. I also have a few more generic prcedures listed here.

Please note that most of the examples on this site were written for Office 2003, but will work (for the most part) on Office 2007 and 2010.

Don't forget to check out the Video Tutorials page!

Fix Badly Imported Formulas

If you have imported formulas from another program, you might have run into this problem where an apostrophe gets added to the beginning of each formula; so instead of viewing the results of the formula, you are viewing the formula itself. This code will fix that; just highlight the offending data and run.

Sub FixFormulas()
Dim arrData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long

' let's not accidently use this on a non-Range object
If TypeName(Selection) <> "Range" Then Exit Sub

lRows = Selection.Rows.Count
lCols = Selection.Columns.Count

ReDim arrData(1 To lRows, 1 To lCols)

Set rng = Selection
arrData = rng.Value

For j = 1 To lCols
  For i = 1 To lRows
    arrData(i,j) = "=" & Right(arrData(i,j), Len(arrData(i,j)) - 1)
 Next i
Next j

rng.Value = arrData

Set rng = Nothing
End Sub

This code should be lightning fast, even with large amounts of data, because it loops through an array instead of looping through the worksheet. Because of this, we also don't need to set ScreenUpdating to False.

Convert phone numbers

I use the following code to put phone numbers into a standard format. This will remove punctuation and most odd characters people usually put in phone number cells. You will have to remove any suffixes such as extension before running this code.

Sub Convert_Phone()
Application.ScreenUpdating = False
'
' first highlight the cells you want to scrub
'
With Selection.SpecialCells(xlConstants)
   .Replace what:=Chr(160), Replacement:="", LookAt:=xlPart, _
	SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:=Chr(32), Replacement:="", LookAt:=xlPart, _
	SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:=")", Replacement:="", LookAt:=xlPart, _
	SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:="(", Replacement:="", LookAt:=xlPart, _
	SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:="-", Replacement:="", LookAt:=xlPart, _
	SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:="+", Replacement:="", LookAt:=xlPart, _
	SearchOrder:=xlByColumns, MatchCase:=True
End With

' at this point you could do one of two things:
' 1. do a "virtual" format where you just make the cell *appear* to be a
' phone number.
' Selection.NumberFormat = "(###) ###-####"

' 2. We can actually insert the parentheses and dash in the appropriate place.
'
' For each cell in Selection
'  cell = "(" & Left(cell, 3) & ") " & Mid(cell, 4, 3) & "-" & Right(cell, 4)
' Next cell
'
' uncomment whichever one you want!
'
'
Application.ScreenUpdating = True
End Sub

Paste Values in Selected Cells

If you have a large block of formula cells you want to convert to their values, this code will do it. Select the cells and then run this code.

Sub Paste_Values()
Application.ScreenUpdating = False

With Selection
   .Copy
   .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, _
	Transpose:=False
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Delete Empty Rows

Highlight the block of cells you want to act on, otherwise it will act on the entire used range.

Sub Del_Empty_Rows()
Dim R As Long
Dim rng As Range
Application.ScreenUpdating = False

If Selection.Rows.Count > 1 Then
   Set rng = Selection
Else
   Set rng = ActiveSheet.UsedRange.Rows
End If

For R = rng.Rows.count To 1 Step -1
   If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then
      rng.Rows(R).EntireRow.Delete
   End If
Next R

Application.ScreenUpdating = True
End Sub

Selective Autofilter

When you want your end users to only filter on one column. This code assumes that the data is in a contiguous text block and the headers are in row 1.

Sub AutoFilter_Arrows_Hide()
Dim Col As Range
Dim i As Integer
Dim ShowCol As Integer
Application.ScreenUpdating = False

' how many used cells in row 1?
i = Cells(1, 1).End(xlToRight).Column

' prompt user for column that should show autofilter arrow
ShowCol = InputBox("Only allow filter in column number...")

' show autofilter arrow only for matching column
For Each Col In Range(Cells(1, 1), Cells(1, i))
   If Col.Column <> ShowCol Then
      Col.AutoFilter Field:=Col.Column, visibledropdown:=False
   Else
      Col.AutoFilter Field:=Col.Column, visibledropdown:=True
   End If
Next Col

Application.ScreenUpdating = True
End Sub

Remove Hyperlinks

Highlight the block of cells you want to act on, then run this code. All of the hyperlinks (WWW, email, etc) will be removed, leaving the data intact.

Sub Remove_Hyperlinks()
If TypeName(Selection) <> "Range" Then Exit Sub
Application.ScreenUpdating = False
Selection.Hyperlinks.Delete
Application.ScreenUpdating = True
End Sub

You may also want to turn off the automatic conversion of hyperlinks. You can also do it inline or using code found here.

Toggle personal.xls workbook hidden/visible

If you are lazy like me, you will appreciate this code.

You cannot edit macros in a hidden workbook, so when you are debugging code you need to constantly hide/unhide your personal.xls workbook.

This code takes advantage of the fact that the Visible property of a Window is Boolean (True or False) so you can use the 'Not' keyword to switch the current value of Visible to its opposite, every time you run the macro. So when the personal workbook is visible, this hides it, and vice versa. Very effective when you assign a hotkey to this macro.

Sub Unhide_PERSONALXLS()
Dim unhide As Boolean
unhide = Windows("PERSONAL.XLS").Visible
Windows("PERSONAL.XLS").Visible = Not unhide
End Sub

Rename Worksheet

This code will take the name of the workbook and give the first worksheet the same name. Makes your workbook look more professional, like you spent a lot of time on it. Keep in mind this won't work if the filename is >26 characters, which I believe is the length limit of a worksheet tab.

Sub Rename_Sheet()
Dim workbookName As String
  workbookName = ActiveWorkbook.Name
  If Len(workbookName) > 26 Then Exit Sub
  workbookName = Left(workbookName, Len(workbookName) - 4)
  Sheets(1).Name = workbookName
End Sub

Remove Zip Code Suffix (if found)

Highlight a mixed list of zip codes (12345 and 12345-6789) and run this code to remove the last 4. Remember if you run this code then any zip codes starting with '0' (NJ, MA, CT) will get truncated.

Sub Fix_ZIP_plus4()
Dim arrData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long

' let's not accidently use this on a non-Range object
If TypeName(Selection) <> "Range" Then Exit Sub

lRows = Selection.Rows.Count
lCols = Selection.Columns.Count

ReDim arrData(1 To lRows, 1 To lCols)

Set rng = Selection
arrData = rng.Value

For j = 1 To lCols
  For i = 1 To lRows
    If Len(Trim(arrData(i,j))) > 5 Then
      arrData(i,j) = Left(arrData(i,j), Len(arrData(i,j)) - (Len(arrData(i,j)) - 5))
    End If
 Next i
Next j

rng.Value = arrData

Set rng = Nothing
End Sub

This code assumes that you have highlighted a group of cells consisting of mixed zip codes. You could also accomplish the same thing in Excel with a formula: =IF(LEN(A1)>5,LEFT(A1,5),A1) — fill down as needed.

List workbook defined names

The following code will make a list of the defined names in a given workbook on a new worksheet. You'll end up with a list of the names and the range they refer to.

Sub ShowNames()
' list workbook names on separate worksheet
Dim x As Worksheet
Set x = Worksheets.Add

Dim nm As Name
Dim i As Long

i = 1

For Each nm In Names
  Cells(i, 1) = nm.Name
  Cells(i, 2) = "'" & nm.RefersTo
  i = i + 1
Next nm

End Sub

Site last updated: August 20, 2014

Excel School