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

Back

‘ 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

Back

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

Back

‘ 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

Back

‘ 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

Back

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

Back

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

Back