Microsoft Excel VBA Examples

• Send Outlook Mail Message: This sub sends an Outlook mail message from Excel.
• Show Index No. & Name of Shapes:  To show the index number (ZOrderPosition) and name of all shapes on a worksheet.
• Create a Word Document:   To create, open and put some text on a MS Word document from Excel.
• Find:  This is a sub that uses the Find method to find a series of dates and copy them to another worksheet.
• Arrays:  An example of building an array.  You will need to substitute meaningful information for the elements.
• Replace Information:   This sub will find and replace information in all of the worksheets of the workbook.
• Move Minus Sign:  If you download mainframe files that have the nasty habit of putting the negative sign (-) on the right-hand side, this sub will put it where it belongs.  I have seen much more elaborate routines to do this, but this has worked for me every time.
• Counting: Several subs that count various things and show the results in a Message Box.
• Selecting: Some handy subs for doing different types of selecting.
• Listing: Various listing subs.
• Delete Range Names:   This sub deletes all of the range names in the current workbook. This is especially handy for converted Lotus 123 files.
• Type of Sheet: Sub returns in a Message Box the type of the active sheet.
• Add New Sheet: This sub adds a new worksheet, names it based on a string in cell A1 of Sheet 1, checks to see if sheet name already exists (if so it quits) and places it as the last worksheet in the workbook.   A couple of variations of this follow.  The first one creates a new sheet and then copies "some"  information from Sheet1 to the new sheet.  The next one creates a new sheet which is a clone of Sheet1 with a new name.
• Check Values: Various different approaches that reset values. All of the sheet names, range names and cell addresses are for illustration purposes. You will have to substitute your own.
• Input Boxes and Message Boxes: A few simple examples of using input boxes to collect information and messages boxes to report the results.
• Printing: Various examples of different print situations.
• OnEntry: A simple example of using the OnEntry property.
• Enter the Value of a Formula: To place the value (result) of a formula into a cell rather than the formula itself.
• Adding Range Names: Various ways of adding a range name.
• For-Next For-Each Loops: Some basic (no pun intended) examples of for-next loops.
• Hide/UnHide: Some examples of how to hide and unhide sheets.
• Just for Fun:  A sub that inserts random stars into a worksheet and then removes them.
• Unlock Cells:  This sub unlocks all cells that do NOT contain a formula, a date or text and makes the font blue.  It then protects the worksheet.
• Tests the values in each cell of a range and the values that are greater than a given amount are placed in another column.
• Determine the "real" UsedRange on a worksheet.  (The UsedRange property works only if you have kept the worksheet "pure".
• Events:  Illustrates some simple event procedures.
• Dates:   This sub selects a series of dates (using InputBoxes to set the start/stop dates) from a table of consecutive dates, but only lists/copies the workday dates (Monday-Friday).
• Passing Arguments:  An example of passing an argument to another sub.

' You should create a reference to the Outlook Object Library in the VBEditor

Sub Send_Msg()
Dim objOL As New Outlook.Application
Dim objMail As MailItem

Set objOL = New Outlook.Application
Set objMail = objOL.CreateItem(olMailItem)

With objMail
    .To = "name@domain.com"
    .Subject = "Automated Mail Response"
    .Body = "This is an automated message from Excel. " & _
        "The cost of the item that you inquired about is: " & _
        Format(Range("A1").Value, "$ #,###.#0") & "."
    .Display
End With

Set objMail = Nothing
Set objOL = Nothing
End Sub

Back

---

Sub Shape_Index_Name()
Dim myVar As Shapes
Dim shp As Shape
Set myVar = Sheets(1).Shapes

For Each shp In myVar
    MsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _
        & shp.Name
Next

End Sub

---

' You should create a reference to the Word Object Library in the VBEditor

Sub Open_MSWord()
On Error GoTo errorHandler
Dim wdApp As Word.Application
Dim myDoc As Word.Document
Dim mywdRange As Word.Range
Set wdApp = New Word.Application

With wdApp
    .Visible = True
    .WindowState = wdWindowStateMaximize
End With

Set myDoc = wdApp.Documents.Add

Set mywdRange = myDoc.Words(1)

With mywdRange
    .Text = Range("F6") & " This text is being used to test subroutine." & _
        "  More meaningful text to follow."
    .Font.Name = "Comic Sans MS"
    .Font.Size = 12
    .Font.ColorIndex = wdGreen
    .Bold = True
End With

errorHandler:

Set wdApp = Nothing
Set myDoc = Nothing
Set mywdRange = Nothing
End Sub

 

---

Sub ShowStars()
Randomize
StarWidth = 25
StarHeight = 25
    

    For i = 1 To 10
        TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight)
        LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth)
        Set NewStar = ActiveSheet.Shapes.AddShape _
          (msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
        NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
        Application.Wait Now + TimeValue("00:00:01")
        DoEvents
    Next i
    

    Application.Wait Now + TimeValue("00:00:02")
    

Set myShapes = Worksheets(1).Shapes
    For Each shp In myShapes
        If Left(shp.Name, 9) = "AutoShape" Then
            shp.Delete
            Application.Wait Now + TimeValue("00:00:01")
        End If
    Next
    Worksheets(1).Shapes("Message").Visible = True
End Sub

---

' This sub looks at every cell on the worksheet and
' if the cell DOES NOT have a formula, a date or text
' and the cell IS numeric, it unlocks the cell and
' makes the font blue.  For everything else, it locks
' the cell and makes the font black.  It then protects
' the worksheet.
' This has the effect of allowing someone to edit the
' numbers but they cannot change the text, dates or
' formulas.

Sub Set_Protection()
On Error GoTo errorHandler
Dim myDoc As Worksheet
Dim cel As Range
Set myDoc = ActiveSheet
myDoc.UnProtect
For Each cel In myDoc.UsedRange
    If Not cel.HasFormula And _
    Not TypeName(cel.Value) = "Date" And _
    Application.IsNumber(cel) Then
        cel.Locked = False
        cel.Font.ColorIndex = 5
    Else
        cel.Locked = True
        cel.Font.ColorIndex = xlColorIndexAutomatic
    End If
Next
myDoc.Protect
Exit Sub
errorHandler:
MsgBox Error
End Sub

 

---

' Tests the value in each cell of a column and if it is greater
' than a given number, places it in another column.  This is just
' an example so the source range, target range and test value may
' be adjusted to fit different requirements.

Sub Test_Values()
Dim topCel As Range, bottomCel As Range, _
    sourceRange As Range, targetRange As Range
Dim x As Integer, i As Integer, numofRows As Integer
Set topCel = Range("A2")
Set bottomCel = Range("A65536").End(xlUp)
If topCel.Row > bottomCel.Row Then End     ' test if source range is empty
Set sourceRange = Range(topCel, bottomCel)
Set targetRange = Range("D2")
numofRows = sourceRange.Rows.Count
x = 1
For i = 1 To numofRows
    If Application.IsNumber(sourceRange(i)) Then
        If sourceRange(i) > 1300000 Then
            targetRange(x) = sourceRange(i)
            x = x + 1
        End If
    End If
Next
End Sub

---

Sub CountNonBlankCells()               'Returns a count of  non-blank cells in a selection
Dim myCount As Integer                   'using the CountA ws function (all non-blanks)
myCount = Application.CountA(Selection)
MsgBox "The number of non-blank cell(s) in this selection is :  "_
     & myCount, vbInformation, "Count Cells"
End Sub


Sub CountNonBlankCells2()              'Returns a count of non-blank cells in a selection
Dim myCount As Integer                    'using the Count ws function (only counts numbers, no text)
myCount = Application.Count(Selection)
MsgBox "The number of non-blank cell(s) containing numbers is : "_
    & myCount, vbInformation, "Count Cells"
End Sub


Sub CountAllCells                                  'Returns a count of all cells in a selection
Dim myCount As Integer                       'using the Selection and Count properties
myCount = Selection.Count
MsgBox "The total number of cell(s) in this selection is : "_
     & myCount, vbInformation, "Count Cells"
End Sub


Sub CountRows()                                    'Returns a count of the number of rows in a selection
Dim myCount As Integer                       'using the Selection & Count properties & the Rows method
myCount = Selection.Rows.Count
MsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows"
End Sub


Sub CountColumns()                             'Returns a count of the number of columns in a selection
Dim myCount As Integer                      'using the Selection & Count properties & the Columns method
myCount = Selection.Columns.Count
MsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns"
End Sub


Sub CountColumnsMultipleSelections()         'Counts columns in a multiple selection
AreaCount = Selection.Areas.Count
If AreaCount <= 1 Then
    MsgBox "The selection contains " & _
        Selection.Columns.Count & " columns."
Else
    For i = 1 To AreaCount
        MsgBox "Area " & i & " of the selection contains " & _
            Selection.Areas(i).Columns.Count & " columns."
    Next i
End If
End Sub


Sub addAmtAbs()
Set myRange = Range("Range1")   '   Substitute your range here
mycount = Application.Count(myRange)
ActiveCell.Formula = "=SUM(B1:B" & mycount & ")"  '   Substitute your cell address here
End Sub


Sub addAmtRel()
Set myRange = Range("Range1")   '   Substitute your range here
mycount = Application.Count(myRange)
ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)"  '   Substitute your cell address here
End Sub

---

Sub SelectDown()
    Range(ActiveCell, ActiveCell.End(xlDown)).Select
End Sub


Sub Select_from_ActiveCell_to_Last_Cell_in_Column()
Dim topCel As Range
Dim bottomCel As Range
On Error GoTo errorHandler
Set topCel = ActiveCell
Set bottomCel = Cells((65536), topCel.Column).End(xlUp)
    If bottomCel.Row >= topCel.Row Then
        Range(topCel, bottomCel).Select
    End If
Exit Sub
errorHandler:
MsgBox "Error no. " & Err & " - " & Error
End Sub


Sub SelectUp()
    Range(ActiveCell, ActiveCell.End(xlUp)).Select
End Sub


Sub SelectToRight()
    Range(ActiveCell, ActiveCell.End(xlToRight)).Select
End Sub


Sub SelectToLeft()
    Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
End Sub


Sub SelectCurrentRegion()
    ActiveCell.CurrentRegion.Select
End Sub


Sub SelectActiveArea()
    Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
End Sub


Sub SelectActiveColumn()
    If IsEmpty(ActiveCell) Then Exit Sub
    On Error Resume Next
    If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = ActiveCell Else Set TopCell = ActiveCell.End(xlUp)
    If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = ActiveCell Else Set BottomCell = ActiveCell.End(xlDown)
    Range(TopCell, BottomCell).Select
End Sub


Sub SelectActiveRow()
    If IsEmpty(ActiveCell) Then Exit Sub
    On Error Resume Next
    If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
    If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
    Range(LeftCell, RightCell).Select
End Sub


Sub SelectEntireColumn()
    Selection.EntireColumn.Select
End Sub


Sub SelectEntireRow()
    Selection.EntireRow.Select
End Sub


Sub SelectEntireSheet()
    Cells.Select
End Sub


Sub ActivateNextBlankDown()
    ActiveCell.Offset(1, 0).Select
    Do While Not IsEmpty(ActiveCell)
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub


Sub ActivateNextBlankToRight()
    ActiveCell.Offset(0, 1).Select
    Do While Not IsEmpty(ActiveCell)
        ActiveCell.Offset(0, 1).Select
    Loop
End Sub


Sub SelectFirstToLastInRow()
    Set LeftCell = Cells(ActiveCell.Row, 1)
    Set RightCell = Cells(ActiveCell.Row, 256)

    If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
    If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
    If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select
End Sub


Sub SelectFirstToLastInColumn()
    Set TopCell = Cells(1, ActiveCell.Column)
    Set BottomCell = Cells(16384, ActiveCell.Column)

    If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown)
    If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp)
    If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select Else Range(TopCell, BottomCell).Select
End Sub


Sub SelCurRegCopy()
    Selection.CurrentRegion.Select
    Selection.Copy
    Range("A17").Select ' Substitute your range here
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub