Macros

NOTE:  This page is no longer updated.    Most of the topics here are now covered on other pages, or have pages of their own.  However, I will leave this page intact and available.   See the Topics page for a complete list of topics covered on my web site.

These Excel macros and functions were written in VBA version 5, for Microsoft Excel 97.  They may or may not work properly, if at all, in previous versions of Excel.

A frequent question people have is "Can I run a macro from a cell function?   Something like
=IF(A1>10,Macro1)."  The answer is no, you cannot.  However, you can use the worksheet's Change event to do something like this.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Not Application.Intersect(Target, Range("A1")) Is Nothing Then
    If Target.Value > 10 Then
        MsgBox "Put Your Code Here"
    End If
End If
End Sub

Clipboard

The Clipboard page describes the VBA procedures for working with the Windows Clipboard.

Closing All Workbooks

This macro will close all of the workbooks open in Excel.  It requires the SaveAll macro, listed later on this page.

Closing All Inactive Workbooks

This macro will close all of the workbooks, except the active workbook, which will remain open
active.

Public Sub CloseAllInactive()

Dim Wb As Workbook
Dim AWb As String
AWb = ActiveWorkbook.Name

SaveAll
For Each Wb In Workbooks
    If Wb.Name <> AWb Then
        Wb.Close savechanges:=True
    End If
Next Wb
Application.StatusBar = "All Workbooks Closed."

End Sub

Date Functions In VBA

A variety of Date and Time macros and functions are listed on the Date And Time Page.

Other Date Related Procedures are described on the following pages.

Adding Months And Years

The DATEDIF Function

Date Intervals

Dates And Times

Date And Time Entry

Holidays

Julian Dates

Deleting Blank Rows

For macros for deleting blank rows or duplicate rows in an range of cells, click here.

Flipping Or Mirroring A Range

This macro will reverse the order of a range of data.  You may flip data in a single row or in a single column of data (i.e., an N by 1 array or an 1 by N array).   You may not select and entire row or an entire column.

Public Sub FlipSelection()

Dim Arr() As Variant
Dim Rng As Range
Dim C As Range
Dim Rw As Long
Dim Cl As Long

On Error GoTo EndMacro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set Rng = Selection
Rw = Selection.Rows.Count
Cl = Selection.Columns.Count
If Rw > 1 And Cl > 1 Then
   MsgBox "Selection May Include Only 1 Row or 1 Column", _
    vbExclamation, "Flip Selection"
Exit Sub
End If

If Rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then
    MsgBox "You May Not Select An Entire Row", vbExclamation, _
        "Flip Selection"
    Exit Sub
End If
If Rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then
    MsgBox "You May Not Select An Entire Column", vbExclamation, _
        "Flip Selection"
    Exit Sub
End If

If Rw > 1 Then
    ReDim Arr(Rw)
Else
    ReDim Arr(Cl)
End If

Rw = 0
For Each C In Rng
    Arr(Rw) = C.Formula
    Rw = Rw + 1
Next C

Rw = Rw - 1
For Each C In Rng
    C.Formula = Arr(Rw)
    Rw = Rw - 1
Next C

EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

Getting A Built-In Or Custom Document Property

See the Document Properties page for much more detail.

This macro will return the value of a custom or built-in document property.  If the property does not exist, and empty string is returned.

Public Function GetProperty(p As String)
Dim S As Variant

On Error Resume Next

S = ActiveWorkbook.CustomDocumentProperties(p)
If S <> "" Then
    GetProperty = S
    Exit Function
End If

On Error GoTo EndMacro
GetProperty = ActiveWorkbook.BuiltinDocumentProperties(p)
Exit Function

EndMacro:
GetProperty = ""

End Function

Headers And Footers

From the Page Setup dialog, you can set up some basic headers and footers, but you're somewhat limited.  With VBA, however, you can create your own custom headers and footers:

Activesheet.Pagesetup.Leftfooter = "Some Text"

In addition to Leftfooter, you can use CenterFooter, RightFooter, LeftHeader, CenterHeader,or RightHeader.

To include one of the built-in document properties in a footer (or header), use

Activesheet.Pagesetup.Leftfooter =     ActiveWorkbook.Builtinproperties("Manager")

Of course, change "Manager" to the name of the property you want to include.

Highlighting The Active Cell

If you want to make the active cell appear in a special color, use the following code in the Workbook_SheetSelectionChange event of the workbook.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object,
    ByVal Target As Excel.Range)
Static OldRange As Range
On Error Resume Next
Target.Interior.ColorIndex = 6 ' yellow - change as needed
OldRange.Interior.ColorIndex = xlColorIndexNone
Set OldRange = Target

End Sub

This will change the background color of the ActiveCell to yellow anytime you select a new cell, either with the mouse or with the arrow keys.

Download a workbook illustrating this method.

NOTE:  This technique has been greatly enhanced in my RowLiner add-in. I strongly suggest you use RowLiner instead.

Playing WAV Files From VBA

This section has been replaced by the PlaySound page.
It is very simple to have your macro code play a WAV file.  First, add a Windows95 API declaration at the top of your code module:

Declare Function sndPlaySound32 Lib "winmm.dll" Alias _
    "sndPlaySoundA" (ByVal lpszSoundName As String, _
    ByVal uFlags As Long) As Long

Then, call the function, passing it the name of the WAV file you want to play:

Call sndPlaySound32("c:\test\MySound.WAV", 0)

 Printing Comments To Word

This macro will print all of the cell comments to Microsoft Word.  The Word application will remain
open and active.  You may then save or print the cell comment document.    Make sure that
you have enabled references to Word objects, from the Tools->References menu.

Public Sub PrintCellComments()

Dim Cmt As String
Dim C As Range
Dim I As Integer
Dim WordObj As Object
Dim ws As Worksheet
Dim PrintValue As Boolean
Dim res As Integer
On Error Resume Next
Err.Number = 0

res = MsgBox("Do want to print cell values with comments?", _
    vbYesNoCancel + vbQuestion, "Print Cell Comments")
Select Case res
    Case vbCancel
        Exit Sub
    Case vbYes
        PrintValue = True
    Case Else
        PrintValue = False
End Select

Set WordObj = GetObject(, "Word.Application")
If Err.Number = 429 Then
    Set WordObj = CreateObject("Word.Application")
    Err.Number = 0
End If

WordObj.Visible = True
WordObj.Documents.Add
With WordObj.Selection
.TypeText Text:="Cell Comments In Workbook: " + ActiveWorkbook.Name
.TypeParagraph
.TypeText Text:="Date: " + Format(Now(), "dd-mmm-yy hh:mm")
.TypeParagraph
.TypeParagraph
End With

For Each ws In Worksheets
    For I = 1 To ws.Comments.Count
        Set C = ws.Comments(I).Parent
        Cmt = ws.Comments(I).Text
        With WordObj.Selection
        .TypeText Text:="Comment In Cell: " + _
            C.Address(False, False, xlA1) + " on sheet: " + ws.Name
        If PrintValue = True Then
            .TypeText Text:=" Cell Value: " + Format(C.Value)
        End If
        .TypeParagraph
        .TypeText Text:=Cmt
        .TypeParagraph
        .TypeParagraph
        End With
    Next I
Next ws

Set WordObj = Nothing
MsgBox "Finished Printing Comments To Word", vbInformation, _
    "PrintCellComments"

End Sub

Printing Formulas To Word

This macro will print all of the cell values and formulas to Microsoft Word.  The Word application will
remain open and active.  You may then save or print the document.  Make sure that
you have enabled references to Word objects, from the Tools->References menu. 

Public Sub PrintFormulasToWord()

Dim Cnt As String
Dim C As Range

Dim WordObj As word.Application
Dim HasArr As Boolean

On Error Resume Next
Err.Number = 0

Set WordObj = GetObject(, "Word.Application")
If Err.Number = 429 Then
    Set WordObj = CreateObject("Word.Application")
    Err.Number = 0
End If

WordObj.Visible = True
WordObj.Documents.Add

With WordObj.Selection
    .Font.Name = "Courier New"
    .TypeText "Formulas In Worksheet: " + ActiveSheet.Name    
    .TypeParagraph
    .TypeText "Cells: " + Selection.Cells(1,1).Address(False,False,xlA1) _             & " to " & Selection.Cells(Selection.Rows.Count,  _
            Selection.Columns.Count).Address(False, False, xlA1)
    .TypeParagraph
    .TypeParagraph
End With

For Each C In Selection
    HasArr = C.HasArray
    Cnt = C.Formula
    If HasArr Then
        Cnt = "{" + Cnt + "}"
    End If
    If Cnt <> "" Then
        With WordObj.Selection
            .Font.Bold = True
            .TypeText C.Address(False, False, xlA1) & ": "
            .Font.Bold = False
            .TypeText Cnt
            .TypeParagraph
            .TypeParagraph
        End With
    End If
Next C
MsgBox "Done printing formulas to Word. ", , "Print Formulas To Word"

End Sub

Returning Arrays From Functions

You can write VBA functions that return an array of values back to Excel.  Click here for details.

Saving And Returning To A Location

These three macros are used to save a location and then return to that location later.   It is
useful when you need to change the Selection range during the execution of a macro, and then
return to the original Selection range when your macro is complete.

Public Sub SaveLocation(ReturnToLoc As Boolean)

Static WB As Workbook
Static WS As Worksheet
Static R As Range

If ReturnToLoc = False Then
    Set WB = ActiveWorkbook
    Set WS = ActiveSheet
    Set R = Selection
Else
    WB.Activate
    WS.Activate
    R.Select
End If

End Sub

To save the current location, call SetSaveLoc.

Public Sub SetSaveLoc()
    SaveLocation (False)
End Sub

To return to the saved location, call GetSaveLoc.

Public Sub GetSaveLoc()
    SaveLocation (True)
End Sub

Saving All Workbooks

This macro will save all of the workbooks open in Excel.

Public Sub SaveAll()

Dim WB As Workbook
For Each WB In Workbooks
    WB.Save
Next WB
Application.StatusBar = "All Workbooks Saved."

End Sub

Selecting The Current Array

If the ActiveCell is part of an array, this macro will select the entire array.

Public Sub SelectArray()

Dim Msg As String

On Error GoTo EndOfMacro
Msg = "Cell is not part of an array."

ActiveCell.CurrentArray.Select
Msg = "Array Selected."


EndOfMacro:
Application.StatusBar = Msg

End Sub

Selecting The Current Named Range

If the ActiveCell is part of a named range, this macro will select the entire named range.
This macro requires the CellInNamedRange function, shown first.

CellInNamedRange

Public Function CellInNamedRange(Rng As Range) As String

Dim N As Name
Dim C As Range
Dim TestRng As Range
On Error Resume Next

For Each N In ActiveWorkbook.Names
    Set C = Nothing
    Set TestRng = N.RefersToRange
    Set C = Application.Intersect(TestRng, Rng)
    If Not C Is Nothing Then
        CellInNamedRange = N.Name
        Exit Function
    End If
Next N
CellInNamedRange = ""

End Function

SelectRange

Public Sub SelectRange()

Dim RngName As String
Dim R As Range
Set R = ActiveCell
Dim Msg As String

Msg = "Active Cell Is Not In A Named Range."
RngName = CellInNamedRange(R)
If RngName <> "" Then
    Range(RngName).Select
    Msg = "Range: " + RngName + " Selected."
End If

Application.StatusBar = Msg

End Sub

Sheet Names

It is very simple to retrieve sheet names in VBA.  They are stored in two collection objects in the ActiveWorkbook object: the Sheets collection and the Worksheets collection.  The Sheets collection contains both worksheets and chart sheets.   The Worksheets collection contains only worksheets.

To retrieve the name of the first sheet in the workbook, use

Public Function FirstSheetName()
    FirstSheetName = Sheets(1).Name
End Function

To retrieve the name of the last sheet in the workbook, use

Public Function LastSheetName()
    LastSheetName = Sheets(Sheets.Count).Name
End Function

You can return an array of all the sheet names with the following

Public Function AllSheetNames()
    Dim Arr() As String
    Dim I as Integer
    Redim Arr(Sheets.Count-1)
    For I = 0 To Sheets.Count - 1
        Arr(i) = Sheets(I+1).Name
    Next I
    AllSheetNames = Arr      ' return a row array OR
    AllSheetNames = Application.Worksheetfunction.Transpose(Arr)
                             ' return a column array
End Function

Sorting Worksheets

See Sorting Worksheets In A Workbook for VBA code to sort worksheets by name.