Microsoft Excel VBA Examples

' 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

.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

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

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

Microsoft Excel VBA Examples

'-----You might want to step through this using the "Watch" feature-----

Sub Accumulate() Dim n As Integer Dim t As Integer

For n = 1 To 10 t = t + n

Next n

MsgBox " The total is " & t End Sub

'-----This sub checks values in a range 10 rows by 5 columns 'moving left to right, top to bottom-----

Sub CheckValues1() Dim rwIndex As Integer Dim colIndex As Integer

For rwIndex = 1 To 10

For colIndex = 1 To 5

If Cells(rwIndex, colIndex).Value <> 0 Then _ Cells(rwIndex, colIndex).Value = 0

Next colIndex Next rwIndex

End Sub

'-----Same as above using the "With" statement instead of "If"-----

Sub CheckValues2() Dim rwIndex As Integer Dim colIndex As Integer

For rwIndex = 1 To 10

For colIndex = 1 To 5

With Cells(rwIndex, colIndex)

If Not (.Value = 0) Then Cells(rwIndex, colIndex).Value = 0 End With

Next colIndex Next rwIndex

End Sub

'-----Same as CheckValues1 except moving top to bottom, left to right-----

Sub CheckValues3() Dim colIndex As Integer Dim rwIndex As Integer

For colIndex = 1 To 5

For rwIndex = 1 To 10

If Cells(rwIndex, colIndex).Value <> 0 Then _ Cells(rwIndex, colIndex).Value = 0

Next rwIndex Next colIndex

End Sub

'-----Enters a value in 10 cells in a column and then sums the values------

Sub EnterInfo() Dim i As Integer Dim cel As Range Set cel = ActiveCell

For i = 1 To 10

cel(i).Value = 100 Next i

cel(i).Value = "=SUM(R[-10]C:R[-1]C)"

End Sub

' Loop through all worksheets in workbook and reset values

' in a specific range on each sheet. Sub Reset_Values_All_WSheets() Dim wSht As Worksheet

Dim myRng As Range Dim allwShts As Sheets Dim cel As Range

Set allwShts = Worksheets For Each wSht In allwShts

Set myRng = wSht.Range("A1:A5, B6:B10, C1:C5, D4:D10")

For Each cel In myRng

If Not cel.HasFormula And cel.Value <> 0 Then cel.Value = 0

End If Next cel

Next wSht

End Sub

Back

' The distinction between Hide(False) and xlVeryHidden:

' Visible = xlVeryHidden - Sheet/Unhide is grayed out. To unhide sheet, you must set ' the Visible property to True.

' Visible = Hide(or False) - Sheet/Unhide is not grayed out

' To hide specific worksheet

Sub Hide_WS1()

Worksheets(2).Visible = Hide ' you can use Hide or False

End Sub

' To make a specific worksheet very hidden

Sub Hide_WS2()

Worksheets(2).Visible = xlVeryHidden End Sub

' To unhide a specific worksheet

Sub UnHide_WS() Worksheets(2).Visible = True

End Sub

' To toggle between hidden and visible

Sub Toggle_Hidden_Visible()

Worksheets(2).Visible = Not Worksheets(2).Visible End Sub

' To set the visible property to True on ALL sheets in workbook

Sub Un_Hide_All() Dim sh As Worksheet

For Each sh In Worksheets

sh.Visible = True Next

End Sub

' To set the visible property to xlVeryHidden on ALL sheets in workbook. ' Note: The last "hide" will fail because you can not hide every sheet

' in a work book.

Sub xlVeryHidden_All_Sheets() On Error Resume Next

Dim sh As Worksheet

For Each sh In Worksheets sh.Visible = xlVeryHidden

Next End Sub

Back

'///....To find and select a range of dates based on the month and year only....\\\

Sub FindDates()

On Error GoTo errorHandler Dim startDate As String Dim stopDate As String Dim startRow As Integer Dim stopRow As Integer

startDate = InputBox("Enter the Start Date: (mm/dd/yy)")

If startDate = "" Then End

stopDate = InputBox("Enter the Stop Date: (mm/dd/yy)")

If stopDate = "" Then End

startDate = Format(startDate, "mm/??/yy") stopDate = Format(stopDate, "mm/??/yy")

startRow = Worksheets("Table").Columns("A").Find(startDate, _ lookin:=xlValues, lookat:=xlWhole).Row

stopRow = Worksheets("Table").Columns("A").Find(stopDate, _ lookin:=xlValues, lookat:=xlWhole).Row

Worksheets("Table").Range("A" & startRow & ":A" & stopRow).Copy _

destination:=Worksheets("Report").Range("A1")

End errorHandler:

MsgBox "There has been an error: " & Error() & Chr(13) _

& "Ending Sub.......Please try again", 48 End Sub

Back

Sub MyTestArray()

Dim myCrit(1 To 4) As String ' Declaring array and setting bounds

Dim Response As String Dim i As Integer

Dim myFlag As Boolean myFlag = False

' To fill array with values

myCrit(1) = "A"

myCrit(2) = "B"

myCrit(3) = "C"

myCrit(4) = "D"

Do Until myFlag = True

Response = InputBox("Please enter your choice: (i.e. A,B,C or D)")

' Check if Response matches anything in array

For i = 1 To 4 'UCase ensures that Response and myCrit are the same case

If UCase(Response) = UCase(myCrit(i)) Then myFlag = True: Exit For

End If Next i

Loop End Sub

Back

'// This sub will replace information in all sheets of the workbook \\ '//...... Replace "old stuff" and "new stuff" with your info ......\\

Sub ChgInfo()

Dim Sht As Worksheet

For Each Sht In Worksheets Sht.Cells.Replace What:="old stuff", _

Replacement:="new stuff", LookAt:=xlPart, MatchCase:=False

Next End Sub

Back

' This sub will move the sign from the right-hand side thus changing a text string into a value.

Sub MoveMinus()

On Error Resume Next Dim cel As Range

Dim myVar As Range Set myVar = Selection

For Each cel In myVar

If Right((Trim(cel)), 1) = "-" Then cel.Value = cel.Value * 1

End If Next

With myVar

.NumberFormat = "#,##0.00_);[Red](#,##0.00)"

.Columns.AutoFit End With

End Sub

Back

' This sub calls the DetermineUsedRange sub and passes ' the empty argument "usedRng".

Sub CallDetermineUsedRange() On Error Resume Next

Dim usedRng As Range

DetermineUsedRange usedRng MsgBox usedRng.Address

End Sub

' This sub receives the empty argument "usedRng" and determines ' the populated cells of the active worksheet, which is stored

' in the variable "theRng", and passed back to the calling sub.

Sub DetermineUsedRange(ByRef theRng As Range) Dim FirstRow As Integer, FirstCol As Integer, _

LastRow As Integer, LastCol As Integer On Error GoTo handleError

FirstRow = Cells.Find(What:="*", _ SearchDirection:=xlNext, _

SearchOrder:=xlByRows).Row FirstCol = Cells.Find(What:="*", _

SearchDirection:=xlNext, _

SearchOrder:=xlByColumns).Column LastRow = Cells.Find(What:="*", _

SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row

LastCol = Cells.Find(What:="*", _

SearchDirection:=xlPrevious, _ SearchOrder:=xlByColumns).Column

Set theRng = Range(Cells(FirstRow, FirstCol), _ Cells(LastRow, LastCol))

handleError: End Sub

Back

'Copies only the weekdates from a range of dates.

Sub EnterDates() Columns(3).Clear

Dim startDate As String, stopDate As String, startCel As Integer, stopCel As Integer, dateRange As Range

On Error Resume Next Do

startDate = InputBox("Please enter Start Date: Format(mm/dd/yy)", "START DATE") If startDate = "" Then End

Loop Until startDate = Format(startDate, "mm/dd/yy") _ Or startDate = Format(startDate, "m/d/yy")

stopDate = InputBox("Please enter Stop Date: Format(mm/dd/yy)", "STOP DATE") If stopDate = "" Then End

Loop Until stopDate = Format(stopDate, "mm/dd/yy") _ Or stopDate = Format(stopDate, "m/d/yy")

startDate = Format(startDate, "mm/dd/yy") stopDate = Format(stopDate, "mm/dd/yy")

startCel = Sheets(1).Columns(1).Find(startDate, LookIn:=xlValues, lookat:=xlWhole).Row stopCel = Sheets(1).Columns(1).Find(stopDate, LookIn:=xlValues, lookat:=xlWhole).Row

On Error GoTo errorHandler

Set dateRange = Range(Cells(startCel, 1), Cells(stopCel, 1))

Call CopyWeekDates(dateRange) ' Passes the argument dateRange to the CopyWeekDates sub.

Exit Sub errorHandler:

If startCel = 0 Then MsgBox "Start Date is not in table.", 64 If stopCel = 0 Then MsgBox "Stop Date is not in table.", 64

End Sub

Sub CopyWeekDates(myRange)

Dim myDay As Variant, cnt As Integer cnt = 1

For Each myDay In myRange

If WeekDay(myDay, vbMonday) < 6 Then With Range("C1")(cnt)

.NumberFormat = "mm/dd/yy"

.Value = myDay End With

cnt = cnt + 1 End If

Next End Sub

Microsoft Excel VBA Examples

Sub ListFormulas()

Dim counter As Integer Dim i As Variant

Dim sourcerange As Range Dim destrange As Range

Set sourcerange = Selection.SpecialCells(xlFormulas)

Set destrange = Range("M1") ' Substitute your range here

destrange.CurrentRegion.ClearContents destrange.Value = "Address" destrange.Offset(0, 1).Value = "Formula"

If Selection.Count > 1 Then For Each i In sourcerange

counter = counter + 1 destrange.Offset(counter, 0).Value = i.Address

destrange.Offset(counter, 1).Value = "'" & i.Formula Next

ElseIf Selection.Count = 1 And Left(Selection.Formula, 1) = "=" Then destrange.Offset(1, 0).Value = Selection.Address

destrange.Offset(1, 1).Value = "'" & Selection.Formula

Else

MsgBox "This cell does not contain a formula"

End If destrange.CurrentRegion.EntireColumn.AutoFit

End Sub

Sub AddressFormulasMsgBox() 'Displays the address and formula in message box

For Each Item In Selection

If Mid(Item.Formula, 1, 1) = "=" Then

MsgBox "The formula in " & Item.Address(rowAbsolute:=False, _ columnAbsolute:=False) & " is: " & Item.Formula, vbInformation

End If Next

End Sub

Back

Sub DeleteRangeNames() Dim rName As Name

For Each rName In ActiveWorkbook.Names rName.Delete

Next rName

End Sub

Back

Sub TypeSheet()

MsgBox "This sheet is a " & TypeName(ActiveSheet) End Sub

Back

Sub AddSheetWithNameCheckIfExists() Dim ws As Worksheet

Dim newSheetName As String

newSheetName = Sheets(1).Range("A1") ' Substitute your range here

For Each ws In Worksheets

If ws.Name = newSheetName Or newSheetName = "" Or IsNumeric(newSheetName) Then MsgBox "Sheet already exists or name is invalid", vbInformation

Exit Sub End If

Sheets.Add Type:="Worksheet" With ActiveSheet

.Move after:=Worksheets(Worksheets.Count)

.Name = newSheetName End With

End Sub

Sub Add_Sheet()

Dim wSht As Worksheet Dim shtName As String

shtName = Format(Now, "mmmm_yyyy") For Each wSht In Worksheets

If wSht.Name = shtName Then

MsgBox "Sheet already exists...Make necessary " & _ "corrections and try again."

Exit Sub End If

Next wSht

Sheets.Add.Name = shtName Sheets(shtName).Move After:=Sheets(Sheets.Count) Sheets("Sheet1").Range("A1:A5").Copy _

Sheets(shtName).Range("A1")

End Sub

Sub Copy_Sheet()

Dim wSht As Worksheet Dim shtName As String

shtName = "NewSheet"

For Each wSht In Worksheets

If wSht.Name = shtName Then

MsgBox "Sheet already exists...Make necessary " & _ "corrections and try again."

Exit Sub End If

Next wSht

Sheets(1).Copy before:=Sheets(1) Sheets(1).Name = shtName

Sheets(shtName).Move After:=Sheets(Sheets.Count) End Sub

Back

Sub ResetValuesToZero2()

For Each n In Worksheets("Sheet1").Range("WorkArea1") ' Substitute your information here

If n.Value <> 0 Then n.Value = 0

End If Next n

End Sub

Sub ResetTest1()

For Each n In Range("B1:G13") ' Substitute your range here

If n.Value <> 0 Then n.Value = 0

End If Next n

End Sub

Sub ResetTest2()

For Each n In Range("A16:G28") ' Substitute your range here

If IsNumeric(n) Then n.Value = 0

End If Next n

End Sub

Sub ResetTest3()

For Each amount In Range("I1:I13") ' Substitute your range here

If amount.Value <> 0 Then amount.Value = 0

End If Next amount End Sub

Sub ResetTest4()

For Each n In ActiveSheet.UsedRange If n.Value <> 0 Then

n.Value = 0 End If

Next n End Sub

Sub ResetValues()

On Error GoTo ErrorHandler

For Each n In ActiveSheet.UsedRange If n.Value <> 0 Then

n.Value = 0 End If

TypeMismatch:

Next n ErrorHandler:

If Err = 13 Then 'Type Mismatch

Resume TypeMismatch End If

End Sub

Sub ResetValues2()

For i = 1 To Worksheets.Count On Error GoTo ErrorHandler

For Each n In Worksheets(i).UsedRange If IsNumeric(n) Then

If n.Value <> 0 Then n.Value = 0

ProtectedCell:

End If End If

Next n ErrorHandler:

If Err = 1005 Then Resume ProtectedCell

End If

Next i End Sub

Back

Sub CalcPay()

On Error GoTo HandleError Dim hours

Dim hourlyPay Dim payPerWeek

hours = InputBox("Please enter number of hours worked", "Hours Worked")

hourlyPay = InputBox("Please enter hourly pay", "Pay Rate") payPerWeek = CCur(hours * hourlyPay)

MsgBox "Pay is: " & Format(payPerWeek, "$##,##0.00"), , "Total Pay" HandleError:

End Sub

Back

'To print header, control the font and to pull second line of header (the date) from worksheet

Sub Printr()

ActiveSheet.PageSetup.CenterHeader = "&""Arial,Bold Italic""&14My Report" & Chr(13) _

& Sheets(1).Range("A1") ActiveWindow.SelectedSheets.PrintOut Copies:=1

End Sub

Sub PrintRpt1() 'To control orientation Sheets(1).PageSetup.Orientation = xlLandscape Range("Report").PrintOut Copies:=1

End Sub

Sub PrintRpt2() 'To print several ranges on the same sheet - 1 copy

Range("HVIII_3A2").PrintOut Range("BVIII_3").PrintOut Range("BVIII_4A").PrintOut

Range("HVIII_4A2").PrintOut

Range("BVIII_5A").PrintOut Range("BVIII_5B2").PrintOut Range("HVIII_5A2").PrintOut Range("HVIII_5B2").PrintOut

End Sub

'To print a defined area, center horizontally, with 2 rows as titles, 'in portrait orientation and fitted to page wide and tall - 1 copy Sub PrintRpt3()

With Worksheets("Sheet1").PageSetup

.CenterHorizontally = True

.PrintArea = "$A$3:$F$15"

.PrintTitleRows = ("$A$1:$A$2")

.Orientation = xlPortrait

.FitToPagesWide = 1

.FitToPagesTall = 1 End With

Worksheets("Sheet1").PrintOut End Sub

Back

' This is a simple example of using the OnEntry property. The Auto_Open sub calls the Action ' sub. The font is set to bold in the ActiveCell if the value is >= 500. Thus if the value is >=500,

' then ActiveCell.Font.Bold = True. If the value is less than 500, then ActiveCell.Font.Bold = False. ' The Auto_Close sub "turns off" OnEntry.

Sub Auto_Open()

ActiveSheet.OnEntry = "Action" End Sub

Sub Action()

If IsNumeric(ActiveCell) Then ActiveCell.Font.Bold = ActiveCell.Value >= 500

End If End Sub

Sub Auto_Close() ActiveSheet.OnEntry = "" End Sub

Back

'These subs place the value (result) of a formula into a cell rather than the formula.

Sub GetSum() ' using the shortcut approach

[A1].Value = Application.Sum([E1:E15]) End Sub

Sub EnterChoice()

Dim DBoxPick As Integer Dim InputRng As Range

Dim cel As Range

DBoxPick = DialogSheets(1).ListBoxes(1).Value Set InputRng = Columns(1).Rows

For Each cel In InputRng If cel.Value = "" Then

cel.Value = Application.Index([InputData!StateList], DBoxPick, 1) End

End If Next

End Sub

Back

' To add a range name for known range

Sub AddName1()

ActiveSheet.Names.Add Name:="MyRange1", RefersTo:="=$A$1:$B$10"

End Sub

' To add a range name based on a selection

Sub AddName2()

ActiveSheet.Names.Add Name:="MyRange2", RefersTo:="=" & Selection.Address()

End Sub

' To add a range name based on a selection using a variable. Note: This is a shorter version

Sub AddName3()

Dim rngSelect As String rngSelect = Selection.Address

ActiveSheet.Names.Add Name:="MyRange3", RefersTo:="=" & rngSelect End Sub

' To add a range name based on a selection. (The shortest version)

Sub AddName4() Selection.Name = "MyRange4" End Sub

Back

Microsoft Excel VBA Examples

Events

The code for a sheet event is located in, or is called by, a procedure in the code section of the worksheet. Events that apply to the whole workbook are located in the code section of ThisWorkbook.

Events are recursive. That is, if you use a Change Event and then change the contents of a cell with your code, this will innate another Change Event, and so on, depending on the code. To prevent this from happening, use:

Application.EnableEvents = False at the start of your code Application.EnabeEvents = True at the end of your code

' This is a simple sub that changes what you type in a cell to upper case. Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False

Target = UCase(Target) Application.EnableEvents = True End Sub

' This sub shows a UserForm if the user selects any cell in myRange Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) On Error Resume Next

Set myRange = Intersect(Range("A1:A10"), Target) If Not myRange Is Nothing Then

UserForm1.Show End If

End Sub

' You should probably use this with the sub above to ensure

' that the user is outside of myRange when the sheet is activated.

Private Sub Worksheet_Activate() Range("B1").Select

End Sub

' In this example, Sheets("Table") contains, in Column A, a list of

' dates (for example Mar-97) and in Column B, an amount for Mar-97. ' If you enter Mar-97 in Sheet1, it places the amount for March in

' the cell to the right. (The sub below is in the code section of ' Sheet 1.)

Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error GoTo iQuitz

Dim cel As Range, tblRange As Range

Set tblRange = Sheets("Table").Range("A1:A48") Application.EnableEvents = False

For Each cel In tblRange

If UCase(cel) = UCase(Target) Then With Target(1, 2)

.Value = cel(1, 2).Value

.NumberFormat = "#,##0.00_);[Red](#,##0.00)" End With

Columns(Target(1, 2).Column).AutoFit Exit For

End If Next

iQuitz:

Application.EnableEvents = True End Sub

'If you select a cell in a column that contains values, the total 'of all the values in the column will show in the statusbar.

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

Dim myVar As Double

myVar = Application.Sum(Columns(Target.Column)) If myVar <> 0 Then

Application.StatusBar = Format(myVar, "###,###") Else

Application.StatusBar = False

End If End Sub