Microsoft Excel Vba Examples.pdf

Microsoft Excel VBA Examples

The intent of this page is to show some useful Excel VBA (Visual Basic for Applications)

examples that I have picked up in the process of creating my own applications. It is not

intended that this page be "state of the art" VBA programming (for that I recommend

microsoft.public.excel.programming) but just fairly simple subroutines that illustrate formats

and how to use the syntax. Most of these routines I wrote myself, but some were "cloned"

from other sources.

Note: I have tried to make these subroutines as "vanilla " as possible, however some of the

subs were copied directly from my applications. In those cases, you will need to substitute

your own sheet names, range names, cell addresses, etc.

Links to Other VBA Sites

• 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.

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

.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

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

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 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

Plik z chomika:

Inne pliki z tego folderu:

Inne foldery tego chomika: