Visual Basicu koodinäiteid ja seletusi MS Exceli baasil
Jaagup Kippar, veebruar 2001

	Käesolev tekst on loodud lootuses, et paberi pealt on mõnikord kergem vajalikke käske üles leida, sinna märkmeid teha ning vahepeal ekraani vaatamisest silmi puhata. Materjal on näidete tööraamatu moodulite valikuline väljatrükk.

Moodul1

Lihtne makro märgistatud ala teksti suuruse ning värvi määramiseks. 

Sub kujundus()
    Selection.Font.Size = 16
    With Selection.Interior
        .ColorIndex = 46
    End With
End Sub

Lahtriploki poole pöördumine
Sub kujundus2()
 Range("c2:d4").Font.Bold = True
 Range("a1:b3").Font.Italic = True
End Sub

Pöördumine raamatu ning nime järgi
Sub kujundus3()
 With Workbooks("vba02.xls").Worksheets("kujundusleht").Cells
  .Font.Bold = False
  .Font.Italic = False
  '.Interior.ColorIndex = 0
  '.Font.Size = 10
  End With
End Sub

Töölehelt väljakutsutav funktsioon
Public Function hypotenuus(kaatet1, kaatet2)
  hypotenuus = Sqr(kaatet1 ^ 2 + kaatet2 ^ 2)
End Function

Massiiv funktsiooni parameetrina. Nii saab ette anda lahtriploki.
Public Function geomeetriline_keskmine(massiiv)
  Dim korrutis, element
  korrutis = 1
  For Each element In massiiv
    korrutis = korrutis * element
  Next element
  geomeetriline_keskmine = korrutis ^ (1 / massiiv.Count)  
      'elementide arvule vastav juur
End Function

Valikuline parameeter. 
Function jargarv(nr, Optional isend = "inimene")
  jargarv = nr & ". " & isend
End Function

Muutuv parameetrite arv
Function loetelu(paik, ParamArray isendid() As Variant)
  Dim tulemus, element, nr
  nr = 0
  For Each element In isendid
    nr = nr + 1
    If nr = 1 Then
      tulemus = element
    Else
      tulemus = tulemus & ", " & element
    End If
  Next element
  If nr = 0 Then
    loetelu = paik & " on tühi"
  Else
   loetelu = paik & ": " & tulemus
  End If
End Function

Kujundusleht

Nupuvajutusel kutsutakse välja alamprogramm nimega kujundus2.
Private Sub CommandButton1_Click()
  kujundus2
End Sub

Andmelugemine

Muutujate deklareerimine kohustuslik
Option Explicit

Sisestuskasti kirjutatav number jõuab tabeli teise rea esimesse lahtrisse.
Sub CommandButton1_Click()
  Cells(2, 1) = InputBox("Sisesta hinne")
End Sub

Vastu võetakse vaid hinne, mis on suurem kui üks ning väiksem või võrdne viiega.
Private Sub CommandButton2_Click()
  Dim hinne
  Do
    hinne = InputBox("Sisesta hinne")
  Loop Until hinne > 1 And hinne <= 5
  Cells(2, 1) = hinne
End Sub

Tsükli abil üsitakse, kuni vastus sobib
Private Sub CommandButton3_Click()
  Dim hinne, teade
  hinne = InputBox("Sisesta hinne")
  If hinne = "" Then 'kui vajutati Cancel
    End
  End If
  Do While Not (hinne > 1 And hinne < 5)
    teade = "Tulemus " & hinne & " ei sobi. Sisesta uuesti"
    hinne = InputBox(teade)
  Loop
  Cells(2, 1) = hinne
End Sub

Tühja alasse kirjutatakse hindeid üksteise alla
Private Sub CommandButton4_Click()
  Dim nr, hinne
  Range("a2:a100").Clear
  nr = 2
  Do
    hinne = InputBox("Sisesta hinne")
    Cells(nr, 1) = hinne
    nr = nr + 1
  Loop Until hinne = ""
End Sub

Lõppu lisamine
Private Sub CommandButton5_Click()
  Dim nr, hinne
  nr = ActiveSheet.UsedRange.Rows.Count + 1
  Do
    hinne = InputBox("Sisesta hinne")
    Cells(nr, 1) = hinne
    nr = nr + 1
  Loop Until hinne = ""
End Sub

Joonistamine

Läbi tuleb ajada olemasolevate kujundite sobivasse kohta asetamisega. Joon lisatakse aktiivse lehe kujundite kollektsiooni Shapes.
Private Sub lihtnejoon_Click()
    ActiveSheet.Shapes.AddLine(300, 10, 300, 100).Select
End Sub

Private Sub ringijoonistus_Click()
   ActiveSheet.Shapes.AddShape(msoShapeOval, Selection.Left, Selection.Top, 10, 10).Select
End Sub

Pärastiseks grupeerimiseks tuleb meelde jätta loodud kujundite nimed. Nelinurka saab tarvitada pildi alusena.
Private Sub joonis1_Click()
  Dim kujundid(1)
  kujundid(0) = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 300, 100, 100, 100).Name
  kujundid(1) = ActiveSheet.Shapes.AddLine(350, 120, 350, 180).Name
  ActiveSheet.Shapes.Range(kujundid).Select
  Selection.ShapeRange.Group.Select
End Sub

Kujundite värvi ja muid omadusi võib programmi abil samuti muuta kui muud moodi.
Private Sub joonis2_Click()
   Dim kujundid(3), abi As Shape, tekstikast As TextBox
    kujundid(0) = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 300, 250, 150, 90).Name
    Set abi = ActiveSheet.Shapes.AddShape(msoShapeOval, 310, 260, 40, 40)
    abi.Line.Visible = msoFalse
    'Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13 'kollane
    abi.Fill.ForeColor.SchemeColor = 13 'kollane
    kujundid(1) = abi.Name
    Set abi = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 410, 260, 40, 20)
    abi.Select
    Selection.Characters.Text = "Päike"
    abi.Line.Visible = msoFalse
    kujundid(2) = abi.Name
    Set abi = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 305, 315, 100, 20)
    abi.Fill.ForeColor.SchemeColor = 17 'rohekas
    kujundid(3) = abi.Name
    ActiveSheet.Shapes.Range(kujundid).Select
    Selection.ShapeRange.Group.Select
End Sub

Diagramm

Massiiv, mille suuruse soovin pärast määrata sõltuvalt algandmetest.
Dim kujundid()

Private Sub Soltuvus_Click()
  Dim pikkus, rida, veerg, xserv, yserv, xkoef, ykoef, xnihe, ynihe
  'Selection tähistab märgitud lahtreid
  If Selection.Columns.Count <> 2 Then
    MsgBox "Märgitud peab olema kaks veergu"
    End
  End If
  'Massiivile antakse ruumi nõnda paljude elementide jaoks,
  'kui palju on kasutaja märgistanud.
  ReDim kujundid(Selection.Rows.Count)
  xserv = 250
  yserv = 50
  'koefitsent näitab, mitu ekraanipunkti vastab ühele ühikule
  'nihke jagu nihutatakse pilti ekraanipunktides
  xkoef = 1: xnihe = -150
  ykoef = 10: ynihe = -35
  kujundid(0) = ActiveSheet.Shapes.AddShape(msoShapeRectangle, xserv, yserv, 150, 150).Name
  pikkus = Selection.Rows.Count
  For rida = 1 To pikkus
    kujundid(rida) = ActiveSheet.Shapes.AddShape(msoShapeOval, _
      xserv + (Selection.Cells(rida, 1) + xnihe) * xkoef, _
      yserv + (Selection.Cells(rida, 2) + ynihe) * ykoef, 10, 10).Name
  Next rida
  ActiveSheet.Shapes.Range(kujundid).Select
  Selection.ShapeRange.Group.Select
  'MsgBox (Selection.Cells(1, 2))
End Sub

Liikumine

Liikumine tekib natukese aja tagant järgnevatest nihutamistest ja joonistamistest. 
Sub oota(millisek)
  Application.Wait (Now() + millisek / 86400000#)  'millisekundeid päevas
End Sub

Private Sub liigu1_Click()
  Dim joon As Shape, y
  Set joon = ActiveSheet.Shapes.AddLine(300, 20, 300, 100)
  y = 20
  Do
    joon.Top = y
    oota (700)
    y = y + 20
  Loop Until y > 100
  joon.Delete
End Sub

Failid

Option Explicit

Lihtne failist lugemine
Private Sub faililugeja_Click()
  Dim rida As String
  Open "c:\nimed.txt" For Input As #1
  Line Input #1, rida
  MsgBox (rida)
  Close #1
End Sub

Faili sisu loetakse ridadena lahtritesse
Private Sub faililugeja2_Click()
  Dim rida As String, failinimi, reanr
  'kasutajalt küsitakse failinimi dialoogiakna kaudu
  failinimi = Application.GetOpenFilename
  Open failinimi For Input As #1
  reanr = 1
  ActiveSheet.Cells.Clear
  Do While Not EOF(1)
    Line Input #1, rida
    Cells(reanr, 1) = rida
    reanr = reanr + 1
  Loop
  Close #1
End Sub

Abiprogramm sõnest failieraldajale järgneva osa mahalõikamiseks
Function ulemkataloog()
  Dim kataloog, nr
  Const failieraldaja = "\"
  kataloog = ActiveWorkbook.Path  'tööraamatu failitee
  nr = Len(kataloog)
  For nr = Len(kataloog) To 1 Step -1
   If Mid(kataloog, nr, 1) = failieraldaja Then Exit For
   'otsitakse failieraldaja asukoht
  Next nr
  MsgBox kataloog & " " & nr    ' kontrolliks kataloog ning nr asukoht selles
  kataloog = Left(kataloog, nr)   ' vaja ainult failiteed
  jooksev_kataloog = kataloog
End Function

Avamisel tekkivade vigadega ümber käimine
Private Sub faililugeja3_Click()
  Dim failinimi, nr, rida
  failinimi = "nimed.txt"
  failinimi = InputBox("Palun faili nimi", "Faili avamine", _
    ActiveWorkbook.Path & "\" & failinimi)
  On Error GoTo veahaldus
avamine:
  Open failinimi For Input As #1
  Line Input #1, rida
  MsgBox ("Esimesel real on " & rida)
  Close #1
  Exit Sub
  
veahaldus:
Do While Not failinimi = ""
 If Err.Number = 53 Then 'veale "faili ei leitud" vastav kood
  failinimi = InputBox("Kontrollige failinime", "faili ei leitud", failinimi)
  If Not (failinimi = "" Or FileSystem.Dir(failinimi) = "") Then
    GoTo avamine
  End If
 Else  'muu veanumbri korral
   MsgBox "Viga: " & Err.Description
   Exit Sub
 End If
Loop
End Sub

Sisseloetavate ridade jaotamine lahtritesse
Private Sub faililugeja4_Click()
  Dim failinimi, rida, reanr As Integer, eralduskoht(2)
  Const eraldaja = ","
  reanr = 1
  failinimi = ActiveWorkbook.Path & "\nimed2.txt"
  Open failinimi For Input As #1
  ActiveSheet.Cells.Clear
  Range("a1:c1") = Array("Nimi", "Sünniaasta", "Telefon")
  Do While Not EOF(1)
    Line Input #1, rida
    eralduskoht(1) = InStr(1, rida, eraldaja)
    eralduskoht(2) = InStr(eralduskoht(1) + 1, rida, eraldaja)
    reanr = reanr + 1
    Cells(reanr, 1) = Mid(rida, 1, eralduskoht(1) - 1)
    Cells(reanr, 2) = Mid(rida, eralduskoht(1) + 1, _
       eralduskoht(2) - eralduskoht(1) - 1)
    Cells(reanr, 3) = Mid(rida, eralduskoht(2) + 1)
  Loop
  Close #1
End Sub

Lihtne väljatrükk faili
Private Sub kirjutus1_Click()
  Open "tervitus.txt" For Output As #1
  Print #1, "Tere"
  Close #1
End Sub

Andmete väljastamine HTML faili
Private Sub kirjutaHTML_Click()
  Dim reanr, veerunr, ala As Range
  ActiveSheet.Range("a1").Select
  Set ala = ActiveCell.CurrentRegion  'lahtriga ühendatud piiritletud ala
  Open Application.GetSaveAsFilename( _
    "katsetus.html", "HTMLi failid (*.html), *.html", 1, _
    "Veebilehe salvestamine", "Valmis" _
  ) For Output As #1
  Print #1, "<html><head><title>Osalejate tabel</title></head>" & Chr(13) & _
            "<body> " & Chr(13) & _
       "<table border><tr><td>Nimi</td><td>Sünniaasta</td><td>Telefon</td>" & Chr(13)
  For reanr = 2 To ala.Rows.Count
    Print #1, "<tr>" & Chr(13)
    For veerunr = 1 To 3
      Print #1, " <td>" & ala.Cells(reanr, veerunr) & "</td>" & Chr(13)
    Next veerunr
  Next reanr
  Print #1, "</table></body></html>"
  Close #1
End Sub

Andmevorm

	Vormi aknas saab sisestada ja juhtida enamikku tegevusi, mida tavaliste sisestamiste ja arvutamiste juures võib vaja minna. Algselt tuleb graafikakomponendid oma kohale paigutada ning siis saab nende juurde kuuluvate sündmuste peale programmilõike käivitada. 

Vormi avamine
Private Sub CommandButton3_Click()
  Nimevorm3.Show
End Sub

Nimevorm

Option Explicit
Dim reanr
Private Sub nimevorm_show()
  reanr = 0
End Sub

Private Sub katkesta_Click()
  Nimevorm.Hide
End Sub

Private Sub korras_Click()
   reanr = reanr + 1
   Cells(reanr, 1) = nimi.Value
   Cells(reanr, 2) = hinne.Value
   nimi.Value = ""
   hinne.Value = ""
End Sub

Nimevorm2

Hinnete sisestuskontroll
Option Explicit
Dim reanr
Private Sub katkesta_Click()
  Hide
End Sub

Private Sub korras_Click()
 Dim sobib, hindenr
 sobib = True
 hindenr = Val(hinne.Value)
 If Len(nimi.Value) < 3 Then
   Beep
   MsgBox ("Liialt lühike nimi")
   sobib = False
 ElseIf hindenr < 1 Or hindenr > 5 Then
   MsgBox ("Sobimatu hinne")
   sobib = False
 End If
 If sobib Then
   reanr = reanr + 1
   Cells(reanr, 1) = nimi.Value
   Cells(reanr, 2) = hinne.Value
   nimi.Value = ""
   hinne.Value = ""
 End If
 nimi.SetFocus
End Sub

Nimevorm3

Graafikakomponentidega vorm. 
Nimistusse tuleb elemendid sisestada vormi avamisel.
Raadionupud hakkavad tööle, kui need on ühisesse raami paigutatud.

Option Explicit
Dim reanr

Private Sub CommandButton1_Click()
  Dim keelestr, soostr, vallalisstr, rida
  reanr = reanr + 1
  keelestr = ""
  For rida = 0 To keeled.ListCount - 1
    If keeled.Selected(rida) Then
     keelestr = keelestr & ", " & keeled.List(rida)
    End If
  Next rida
    If Len(keelestr) > 0 Then
      keelestr = Right(keelestr, Len(keelestr) - 2)
    End If
  soostr = "Teadmata"
  If mees.Value = True Then
    soostr = "mees"
  ElseIf naine.Value = True Then
    soostr = "naine"
  End If
  If vallaline.Value = True Then
    vallalisstr = "Vallaline"
  Else
    vallalisstr = "Abielus"
  End If
  Cells(reanr, 1) = hinne.Value
  Cells(reanr, 2) = soostr
  Cells(reanr, 3) = keelestr
  Cells(reanr, 4) = vallalisstr
End Sub

Private Sub CommandButton2_Click()
  Hide
End Sub

Private Sub UserForm_Activate()
  hinne.AddItem ("5")
  hinne.AddItem ("4")
  hinne.AddItem ("3")
  hinne.AddItem ("2")
  
  keeled.MultiSelect = fmMultiSelectExtended
  keeled.AddItem ("Eesti")
  keeled.AddItem ("Vene")
  keeled.AddItem ("Soome")
  keeled.AddItem ("Saksa")
  keeled.AddItem ("Inglise")
End Sub