Excel VBA

Articles in the Excel VBA category:


    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!

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.

1
2
3
4
5
6
7
8
9
10
Sub fixformulas()
'
' if you have some formulas with a ' or some other character
' in the beginning
'
Dim cell As Excel.Range
For Each cell In Selection
    cell = "=" & Right(cell, Len(cell) - 1)
Next cell
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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
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.

1
2
3
4
5
6
7
8
9
10
11
12
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.

1
2
3
4
5
6
7
8
9
10
11
12
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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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.

1
2
3
4
5
6
7
Sub Remove_Hyperlinks()
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.

1
2
3
4
5
6
Sub Unhide_PERSONALXLS()

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 worksheet the same name. Makes your worksheets look slick! Keep in mind this won't work if the filename is >26 characters, which I believe is the length limit of a worksheet tab.

1
2
3
4
5
6
7
Sub Rename_Sheet()

X = ActiveWorkbook.Name
X = Left(X, Len(X) - 4)
Sheets(1).Name = X

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.

1
2
3
4
5
6
7
8
9
10
11
12
Sub Fix_ZIP_plus4()
Dim cell As Excel.Range
Application.ScreenUpdating = False

For Each cell In Selection
   If Len(Trim(cell)) > 5 Then
      cell = Left(cell, Len(cell) - (Len(cell) - 5))
   End If
Next cell

Application.ScreenUpdating = True
End Sub

    You could also do this directly in Excel with a formula: =IF(LEN(A1)>5,LEFT(A1,5),A1) — fill down as needed.

Create Default Workbooks/Worksheets

Create Default Workbook Template (book.xlt)

  1. Create a blank workbook, customized with number of sheets, fonts, styles etc.
  2. Hit F12 to save the workbook, in the 'Save As Type' dropdown, choose 'Template'
  3. For the filename, type 'book' (to save the template as book.xlt in your XLSTART folder)

This will be the default workbook whenever you start Excel.

Create Default Worksheet Template (sheet.xlt)

  1. Create a blank worksheet, customized with fonts, styles, zoom etc.
  2. Hit F12 to save the workbook, in the 'Save As Type' dropdown, choose 'Template'
  3. For the filename, type 'sheet' (to save the template as sheet.xlt in your XLSTART folder)

This will be the default worksheet whenever you Insert>Worksheet (or Shift-F11).



Buy Chandoo's Excel Formula E-book