Excel VBA Examples(2)

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

Set objOL = New Outlook.ApplicationSet 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") & ".".DisplayEnd With

Set objMail = NothingSet objOL = NothingEnd Sub

Back

Sub Shape_Index_Name()Dim myVar As ShapesDim shp As ShapeSet myVar = Sheets(1).Shapes

For Each shp In myVarMsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _& shp.NameNext

End Sub

Back

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

Sub Open_MSWord()On Error GoTo errorHandlerDim wdApp As Word.ApplicationDim myDoc As Word.DocumentDim mywdRange As Word.RangeSet wdApp = New Word.Application

With wdApp.Visible = True.WindowState = wdWindowStateMaximizeEnd 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 = TrueEnd With

errorHandler:

Set wdApp = NothingSet myDoc = NothingSet mywdRange = NothingEnd Sub

Back

Sub ShowStars()RandomizeStarWidth = 25StarHeight = 25

    For i = 1 To 10TopPos = 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")DoEventsNext i

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

Set myShapes = Worksheets(1).ShapesFor Each shp In myShapesIf Left(shp.Name, 9) = "AutoShape" Thenshp.DeleteApplication.Wait Now + TimeValue("00:00:01")End IfNextWorksheets(1).Shapes("Message").Visible = TrueEnd 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 RangeDim x As Integer, i As Integer, numofRows As IntegerSet topCel = Range("A2")Set bottomCel = Range("A65536").End(xlUp)If topCel.Row > bottomCel.Row Then End     ‘ test if source range is emptySet sourceRange = Range(topCel, bottomCel)Set targetRange = Range("D2")numofRows = sourceRange.Rows.Countx = 1For i = 1 To numofRowsIf Application.IsNumber(sourceRange(i)) ThenIf sourceRange(i) > 1300000 ThentargetRange(x) = sourceRange(i)x = x + 1End IfEnd IfNextEnd Sub

Back

Sub CountNonBlankCells()               ‘Returns a count of  non-blank cells in a selectionDim 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 SubSub CountNonBlankCells2()              ‘Returns a count of non-blank cells in a selectionDim 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 SubSub CountAllCells                                  ‘Returns a count of all cells in a selectionDim myCount As Integer                       ‘using the Selection and Count propertiesmyCount = Selection.CountMsgBox "The total number of cell(s) in this selection is : "_& myCount, vbInformation, "Count Cells"End SubSub CountRows()                                    ‘Returns a count of the number of rows in a selectionDim myCount As Integer                       ‘using the Selection & Count properties & the Rows methodmyCount = Selection.Rows.CountMsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows"End SubSub CountColumns()                             ‘Returns a count of the number of columns in a selectionDim myCount As Integer                      ‘using the Selection & Count properties & the Columns methodmyCount = Selection.Columns.CountMsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns"End SubSub CountColumnsMultipleSelections()         ‘Counts columns in a multiple selectionAreaCount = Selection.Areas.CountIf AreaCount <= 1 ThenMsgBox "The selection contains " & _Selection.Columns.Count & " columns."ElseFor i = 1 To AreaCountMsgBox "Area " & i & " of the selection contains " & _Selection.Areas(i).Columns.Count & " columns."Next iEnd IfEnd SubSub addAmtAbs()Set myRange = Range("Range1")   ‘   Substitute your range heremycount = Application.Count(myRange)ActiveCell.Formula = "=SUM(B1:B" & mycount & ")"  ‘   Substitute your cell address hereEnd SubSub addAmtRel()Set myRange = Range("Range1")   ‘   Substitute your range heremycount = Application.Count(myRange)ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)"  ‘   Substitute your cell address hereEnd Sub

Back

Sub SelectDown()Range(ActiveCell, ActiveCell.End(xlDown)).SelectEnd SubSub Select_from_ActiveCell_to_Last_Cell_in_Column()Dim topCel As RangeDim bottomCel As RangeOn Error GoTo errorHandlerSet topCel = ActiveCellSet bottomCel = Cells((65536), topCel.Column).End(xlUp)If bottomCel.Row >= topCel.Row ThenRange(topCel, bottomCel).SelectEnd IfExit SuberrorHandler:MsgBox "Error no. " & Err & " - " & ErrorEnd SubSub SelectUp()Range(ActiveCell, ActiveCell.End(xlUp)).SelectEnd SubSub SelectToRight()Range(ActiveCell, ActiveCell.End(xlToRight)).SelectEnd SubSub SelectToLeft()Range(ActiveCell, ActiveCell.End(xlToLeft)).SelectEnd SubSub SelectCurrentRegion()ActiveCell.CurrentRegion.SelectEnd SubSub SelectActiveArea()Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).SelectEnd SubSub SelectActiveColumn()If IsEmpty(ActiveCell) Then Exit SubOn Error Resume NextIf 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).SelectEnd SubSub SelectActiveRow()If IsEmpty(ActiveCell) Then Exit SubOn Error Resume NextIf 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).SelectEnd SubSub SelectEntireColumn()Selection.EntireColumn.SelectEnd SubSub SelectEntireRow()Selection.EntireRow.SelectEnd SubSub SelectEntireSheet()Cells.SelectEnd SubSub ActivateNextBlankDown()ActiveCell.Offset(1, 0).SelectDo While Not IsEmpty(ActiveCell)ActiveCell.Offset(1, 0).SelectLoopEnd SubSub ActivateNextBlankToRight()ActiveCell.Offset(0, 1).SelectDo While Not IsEmpty(ActiveCell)ActiveCell.Offset(0, 1).SelectLoopEnd SubSub 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).SelectEnd SubSub 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).SelectEnd SubSub SelCurRegCopy()Selection.CurrentRegion.SelectSelection.CopyRange("A17").Select ‘ Substitute your range hereActiveSheet.PasteApplication.CutCopyMode = FalseEnd Sub

Back