Excel VBA
- Acronyms in Excel
- Airport Information using XMLHTTP
- Application-level Properties
- Automate Internet Explorer
- Automated Word Mail Merge From Excel
- Baby Activity Tracker Worksheet
- Buzzword Bingo
- Calculation Mode and Excel Optimization
- Case Changing in Excel
- Charting Add-Ins by Peltier Technical Services
- Check If Office App Is Running
- Comment Shape Formatting
- Create Data Queries
- Custom Lists in Excel
- Daily Time Log Workbook
- Early Late Binding
- Excel Add-In (XLA) Best Practices and Design Techniques
- Excel Dashboards
- Excel's Character Set Workbook
- Face ID Toolbar Generator
- Fix State Names
- Formatting SSN
- Freeze Excel Panes with VBA
- How To: Return a list of filenames using GetOpenFilename
- Latitude Longitude Functions
- List Names in Workbook
- List of Enumerated Constants for Late Bound VBA Automation
- Merge Workbooks
- Password Strength Checker
- Periodic Table of Elements fetching with XMLHTTP
- Process all Files in a Folder
- Rows To Repeat At Top
- Sample Outlook Automation
- Search Engine Browsing
- Send Email from Excel
- Send worksheets by email as separate workbooks
- Sort Excel 2003 Ranges By Color
- The Bible In Excel
- Validate Filenames
- varType Function
- Workbook and Worksheet Templates
- Write values to a header row
- Video Tutorials
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
' 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