Excel VBA

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 Excel VBA routines listed here.

To read about early & late binding, check out the Early/Late Binding page.

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

Periodically you will see new articles added to this section. To receive notification when new articles are published, subscribe to the site feed.

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)
ReDim arrReturnData(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

Random Date Select

This macro uses a blank throwaway worksheet to choose a random date in between two dates that you specify. Please note this code is a bit old and wouldn't be the way I do it today, it is just posted here for illustration of various VBA techniques you may be able to apply to your own project.

Sub RandomDateSelect()

Dim cell As Range, c As Excel.Worbook
Dim X As String, count As Integer
Dim StartDate As Date, EndDate As Date
Const APPNAME As String = "Random Date Select"

Application.ScreenUpdating = False

Set c = Workbooks.Add

X = InputBox("Enter start and end dates" & vbCr & vbCr & _
"Enter dates separated by commas, i.e." & vbCr & _
"10-1-2003, 12-1-2004", APPNAME)
If X = "" Then Exit Sub

With WorksheetFunction
StartDate = CDate(Trim(Left(X, .Find(",", X) -1)))
EndDate = CDate(Trim(Mid(X, .Find(",", X) + 1)))
End With

If StartDate > EndDate Then Exit Sub

count = EndDate - StartDate

' fill cells with consecutive dates
For i = 1 To count + 1
Cells(i, 1).Value = StartDate
StartDate = StartDate + 1
Next i

Range(Selection, Selection.End(xlDown)).Select

Selection.Offset(0, 1).Select
Selection.FormulaR1C1 = "=RAND()"

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

Range(Selection.End(xlToLeft), Selection.End(xlDown)).Select
Selection.Sort Key1:=Selection.End(xlToRight), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

If Format(Cells(1, 1).Value, "dddd") = "Saturday" Then
MsgBox (Cells(3, 1).Value & " was randomly selected.")
ElseIf Format(Cells(1, 1).Value, "dddd") = "Sunday" Then
MsgBox (Cells(2, 1).Value & " was randomly selected.")
Else
MsgBox (Cells(1, 1).Value & " was randomly selected.")

c.Close savechanges:=False

Application.ScreenUpdating = True

End Sub

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 section you want to work on
'
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

Delete Error Conditions

This will clear any cells in your selected range if their value is "#N/A". This is the "quick and dirty" way, as you can also create a Range object consisting of only the error cells, and call the ClearContents Method on that.

Sub Clear_ISNA()
Dim cell As Excel.Range
Application.ScreenUpdating = False

For Each cell In Selection
If WorksheetFunction.IsNA(cell) Then
cell.ClearContents
End If
Next cell

Application.ScreenUpdating = True
End Sub

Paste Values in Selected Cells

If you have a large block of formula cells you want to convert to values, this code will do it.

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

i = Cells(1, 1).End(xlToRight).Column

ShowCol = InputBox("Only allow filter in column number...")

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

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 trunc'ed.

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)
ReDim arrReturnData(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

Code For Excel And Outlook