Hieronder staan een aantal kleine VBA scripts die gebruikt kunnen worden om mee te oefenen, met onder andere een programma om te bepalen of een getal priem is. Grotere toepassingen  van VBA worden in afzonderlijke artikelen behandeld. In het artikel Visual Basic for Aplications staat een uitgebreide werkinstructie hoe een VBA script kan worden ingevoerd in een Excelbestand.

Boekentip VBA

Wil je meer weten over VBA? Het volgende boek biedt stevig houvast.

 

Cursus VBA

Of volg een cursus VBA. Bij SignOn worden zeer goede trainingen gegeven.

VBA scripts

Rij toevoegen in een tabel op basis van de waarde van een cel (bijvoorbeeld ‘Totaal’)

Sub VoegRijToeOnderaanTabel()

‘Stel variabelen vast

Dim x As Integer

Dim y As Double

Dim i As Integer

‘Stel het aantal rijen met waarden vast (y-x)

y = Rows.Count

x = Cells(y, 1).End(xlUp).Row

‘Zoekt en selecteert in eerste kolom

Columns(1).Select

For i = 1 To x

If (ActiveCell.Value) Like “Totaal” Then

Selection.EntireRow.Insert

x = x – 1

Else

‘Selecteer de volgende cel

ActiveCell.Offset(1, 0).Select

End If

Next i

End Sub

Als je rijen wilt verwijderen dan wil je misschien de rij met ‘Totaal’wel beschermen

Sub VerwijderRijBeschermTotaal()

If (ActiveCell.Value) Like “Totaal” Then

ActiveCell.Offset(-1, 0).Select

End If

Selection.EntireRow.Delete

End Sub

Is het een priemgetal of niet?

Sub priem1()

Dim AantalNoemers As Long, Getal As Long, i As Long

Dim A As String

AantalNoemers = 0

A = MsgBox(“Wilt u een getal proberen?”, [vbYesNo])

‘VBA code: 6 = Yes, 7 = No

Do While A = 6

Getal = InputBox(“Voer getal in”)

For i = 1 To Getal

If Getal Mod i = 0 Then

AantalNoemers = AantalNoemers + 1

End If

Next i

If AantalNoemers = 2 Then

MsgBox number & ” dit is een priemgetal”

Else

MsgBox number & ” dit is geen priemgetal”

End If

A = MsgBox(“Wilt u een nog getal uitproberen?”, [vbYesNo])

‘VBA code: 6 = Yes, 7 = No

If A = 7 Then

MsgBox “Ok, tot de volgende keer!”

Else

End If

Loop

End Sub

Herhalen

Sub herhalen()

Dim tel As Integer

tel = 0

Do While tel <= 5

tel = tel + 1

MsgBox tel

Loop

End Sub

Vermenigvuldigen

Sub Vermenigvuldigen()

Dim t As String, n As Integer

t = 4

n = 3

MsgBox n * t

Eindeloos

Sub Eindeloos()

Dim t As Integer

t = 20

Do While t <= 20 And t > -5

MsgBox t

t = t – 1

Loop

Eindeloos2

Sub Eindeloos2()

Dim t As Integer

t = 20

Do While t <= 20

MsgBox t

t = t – 1

Loop

End Sub

Optellen

Sub Optellen()

Dim x As Long, y As Long

x = 17000

y = x + x

MsgBox y

End Sub

Factoren (tekst, getallen) samenvoegen (Engels: concatenate)

Sub Concatenate()

Dim n As String

Dim x As String

Dim p As String

x = “leen”

p = “appels”

n = x + ” ” + p

MsgBox n

End Sub

Ok knop

Sub OkKnop()

Dim a As Integer

a = 3

MsgBox 3, vbOKOnly

End Sub

Naamplaatje

Sub NaamPlaatje()

Dim Naam As String

Naam = InputBox(“Typ je naam gevolgd door een enter”, “Naamplaatje”, “Piet”)

MsgBox “Hallo” + ” ” + Naam

End Sub

Popgroep

Sub Popgroep()

Dim Popgroep As String

Popgroep = InputBox(“Wat is jouw favoriete popgroep?”, “Popgroep”, “Vul maar in….”, , 1)

MsgBox “Jouw favoriete popgroep is” + ” ” + Popgroep

End Sub

Drie knoppen

Sub DrieKnoppen()

Dim Yes As String

MsgBox “Knoppen Yes, No en Cancel op dit formulier”, vbYesNoCancel + vbInformation + vbDefaultButton3

End Sub

Ok Cancel Knop()

Sub OkCancelKnop()

Dim antwoord As VbMsgBoxResult

antwoord = MsgBox(“Op welke knop ga je klikken?”, vbOKCancel, “Voorbeeld”)

If antwoord = vbOK Then

MsgBox “U heeft op OK geklikt”

Else

MsgBox “U heeft op Cancel geklikt”

End If

MsgBox “Hello World”

MsgBox “Zucht….”

End Sub

Geef een cel een rood kleurtje

Sub RoodKleurtje()

ActiveCell. Select

With Selection.Interior

.Color = 255

End With

End Sub

Laat waarde zien van een bepaalde cel met een messagebox

Sub showvalue()

Contents = Worksheets(“sheet1”).Range(“A1”).Value

MsgBox Contents

End Sub

Verandert de waarde in een bepaalde cel

Sub ChangeValue()

Worksheets(“sheet1”).Range(“A1”).Value = 994.92

End Sub

Tel het aantal openstaande workbooks

Sub Countbooks()

MsgBox Workbooks.Count

End Sub

Verwijder inhoud van bepaalde cel

Sub ClearCell()

Range(“A1”).ClearContents

End Sub

Verwijder inhoud van een range

Sub ClearRange()

Range(“A1”).CurrentRegion.ClearContents

End Sub

Kopieer waarde van cel en plak in de cel daarnaast

Sub CopyOne()

Worksheets(“Sheet1”).Activate

Range(“A1”).Copy Range(“B1”)

End Sub

Voeg een werkmap toe

Sub AddAWorkbook()

Workbooks.Add

End Sub

If-Then: Voorbeeld – Geef met messagebox aan of de waarde kleiner, gelijk of groter is dan iets

Sub IfThen()
Dim Number As Long

Number = Worksheets(“sheet1”).Range(“A1”).Value
If Number > 9 Then
MsgBox “Jeminee groter dan 9”
ElseIf Number = 9 Then
MsgBox “jeeej precies 9!”
Else
MsgBox “Boe! Kleiner dan 9”
End If
End Sub

Do-While: Voorbeeld – Tel 10 op bij elk getal in een reeks tot het einde

Sub dowhile()

Dim i As Integer

i = 1

Do While Cells(i, 1).Value <> “”

Cells(i, 2).Value = Cells(i, 1).Value + 10

i = i + 1

Loop

End Sub

For-Next : Voorbeeld 1 – Ken één voor één een waarde toe aan een range van cellen

Sub ForNext()

Dim i As Integer, j As Integer

For i = 1 To 6

For j = 1 To 2

Cells(i, j).Value = 100

Next j

Next i

End Sub

For-Next: Voorbeeld 2 – Tel 10 op bij ieder getal op een diagonaal

Sub ForNext2()

Dim i As Integer, j As Integer

For i = 1 To 6

For j = 1 To 5

Do While i < 7

Cells(i, j).Value = Cells(i, 1).Value + 10

i = i + 1

j = j + 1

Loop

Next j

Next i

End Sub

Antwoord Ja of Nee / Herhaal

Sub AntwoordJaOfNeeHerhaal()

Dim a As String

Do

a = InputBox(“antwoord met Ja of Nee”)

Loop While a <> “Ja” And a <> “Nee”

End Sub

Test invoer getal (validatie)

Sub TestInvoerGetal()

Dim a As Variant

Do

a = InputBox(“Voer getal in”)

Loop While Not IsNumeric(a)

End Sub

For Next – Tot elf tellen

Sub ForNextTotElfTellen()

Dim tel As Integer

For tel = 1 To 10

MsgBox tel

Next tel

MsgBox “Nu is tel gelijk aan ” & tel

End Sub

For Next – Terugtellen

Sub ForNextTerugtellen()

Dim tel As Single

For tel = 10 To 1 Step -0.5

MsgBox tel

Next tel

MsgBox “Nu is tel gelijk aan ” & tel

End Sub

For Each – Benoem werkbladen

Sub ForEachNoemWerkbladen()

Dim w As Worksheet

For Each w In ActiveWorkbook.Worksheets

MsgBox w.Name

Next w

End Sub

Reeks optellen

Sub ReeksOptellen()

Dim som As Long, teller As Integer, tel As Integer

som = 0

tel = InputBox(“Voer getal in”)

Do While teller <= tel

som = som + teller

teller = teller + 1

Loop

MsgBox (som)

End Sub

Kwadrateren

Sub Kwadrateren()

Dim a As Integer, b As Integer, a2 As Integer, b2 As Integer

a = InputBox(“Voer getal a in”)

b = InputBox(“Voer getal b in”)

a2 = a ^ 2

b2 = b ^ 2

MsgBox “a kwadraat = ” & a2

MsgBox “b kwadraat = ” & b2

End Sub

Eindkapitaal berekenen

Sub EindkapitaalBerekenen()

Dim Bk As Integer, Iv As Single, Lt As Integer, Ek As Long

Bk = InputBox(“Voer beginkapitaal in”)

Iv = InputBox(“Voer rentevoet in”)

Lt = InputBox(“Voer looptijd in”)

Ek = Bk * (1 + Iv) ^ Lt

MsgBox “Uw eindkapitaal bedraagt ” & Ek

End Sub

Omkeren

Sub Omkeren()

Dim a As Integer, b As Integer

a = InputBox(“Voer a in”)

b = InputBox(“Voer b in”)

MsgBox “b = ” & b

MsgBox “a = ” & a

End Sub

Verwisselen I

Sub Verwisselen()

Dim x As Integer, y As Integer

x = InputBox(“Voer x in”)

y = InputBox(“Voer y in”)

MsgBox “x = ” & y

MsgBox “y = ” & x

End Sub

Verwisselen II

Sub Verwisselen2()

Dim x As Integer, y As Integer

x = InputBox(“Voer y in”)

y = InputBox(“Voer x in”)

MsgBox “x = ” & x

MsgBox “y = ” & y

End Sub

Is a gelijk aan b?

Sub Gelijk()

Dim a As Integer, b As Integer

a = InputBox(“Voer a in”)

b = InputBox(“Voer b in”)

If a = b Then

MsgBox “Gelijk”

Else

MsgBox “Ongelijk, probeer opnieuw”

End If

End Sub

Wat is groter of kleiner?

Sub WatIsGroterKleiner()

Dim a As Long

a = InputBox(“Voer a in”)

If a > 0 Then

MsgBox “Groter dan 0”

Else

If a < 0 Then

MsgBox “Kleiner dan 0”

Else

MsgBox “Gelijk aan 0”

End If

End If

End Sub

Wat is het grootste getal?

Sub WatIsHetGrootsteGetal()

Dim a As Long, b As Long, c As Long

a = InputBox(“Voer a in”)

b = InputBox(“Voer b in”)

c = InputBox(“Voer c in”)

If c > a Then

If c > b Then

MsgBox “Het grootste getal = ” & c

End If

Else

If b > a Then

If b > c Then

MsgBox “Het grootste getal = ” & b

End If

Else

MsgBox “Het grootste getal = ” & a

End If

End If

End Sub

Korting berekenen

Sub Korting()

Dim kp As Single, n As Integer, k As Integer

n = InputBox(“Voer stuks in”)

If n < 50 Then

k = n * 5 * 0.02

Else

If n > 100 Then

k = n * 5 * 0.06

Else

k = n * 5 * 0.04

End If

End If

MsgBox “Uw korting bedraagt ” & k & ” euro”

End Sub

Vraag – antwoord / If Else

Sub VraagAntwoordIfElse()

Dim antwoord As String

antwoord = InputBox(“Ja of Nee?”)

If antwoord <> “Ja” Then

If antwoord <> “Nee” Then

MsgBox “Geef antwoord”

Else

MsgBox “U heeft met Nee geantwoord, u krijgt dus geen salaris deze maand”

End If

Else: MsgBox “U heeft met Ja geantwoord, uw salaris wordt overgemaakt aan het goede doel”

End If

MsgBox “Dank voor uw medewerking”

End Sub

Vraag – antwoord / Case

Sub VraagAntwoordCase()

Dim antwoord As String

antwoord = InputBox(“Ja of Nee”)

Select Case antwoord

Case “Ja”

MsgBox “U heeft Ja geantwoord”

Case “Nee”

MsgBox “U heeft Nee geantwoord”

Case Else

MsgBox “Geef antwoord”

End Select

End Sub

 Tot tien en terugtellen

Sub TotTienEnTerugtellen()

Dim tel As Integer

tel = 1

Do While tel < 10

MsgBox tel

tel = tel + 1

Loop

Do While tel >= 0

MsgBox tel

tel = tel – 1

Loop

End Sub

Lege rijen verwijderen in een willekeurig bestand in Excel

Sub DelRow()

Dim x As Integer

Dim y As Double

Dim i As Integer

‘om het aantal rijen in een excelbestand te tellen

y = Rows.Count

x = Cells(y, 1).End(xlUp).Row

Workbooks(2).Activate

Range(“A1”).Select

For i = 1 To x

‘ Checks to see if the active cell is blank.

If IsEmpty(ActiveCell.Value) Then

Selection.EntireRow.Delete

‘ Decrements count each time a row is deleted. This ensures

‘ that the macro will not run past the last row.

x = x – 1

Else

‘ Selects the next cell.

ActiveCell.Offset(1, 0).Select

End If

Next i

Workbooks(1).Activate

End Sub

Verwijder duplicaties (Engels: remove duplicates)

Sub RemoveDuplicates()

Workbooks(2).Activate

Range(“A1”).CurrentRegion.Select

ActiveSheet.Range(“A1”).CurrentRegion.RemoveDuplicates Columns:=4, Header:=xlYes

Workbooks(1).Activate

End Sub

Verwijder records op basis van bepaal criterium

Sub FilterCriteriumABCD()

Dim x As Integer

Dim y As Double

Dim i As Integer

’to count the number of rows in the dataset

y = Rows.Count

x = Cells(y, 1).End(xlUp).Row

Workbooks(1).Activate

Columns(6).Select

For i = 1 To x

If ActiveCell.Value = “CriteriumA” Then

Selection.EntireRow.Delete

Else

ActiveCell.Offset(1, 0).Select

End If

Next

Columns(14).Select

For i = 1 To x

If ActiveCell.Value Like “*CriteriumB*” Or ActiveCell.Value Like “*CriteriumC*” Or ActiveCell.Value Like “*CriteriumD*” Then

Selection.EntireRow.Delete

Else

ActiveCell.Offset(1, 0).Select

End If

Next

End Sub

Maak backup van een worksheet in hetzelfde workbook

Sub backUpSheet()

Workbooks(1).Activate

Worksheets(“Sheet”).Select

Range(“A1”).CurrentRegion.Copy

Worksheets.Add

ActiveSheet.Name = “Backup Output”

Range(“A1”).PasteSpecial

ActiveWorkbook.Sheets(“Backup Output”).Move _

after:=ActiveWorkbook.Sheets(“Output”)

End Sub

Is het een palindroom? Max 5 letters

Sub IsHetEenPalindroomMax5letters()

Dim a As String, b As String, c As String, d As String, e As String

Dim woord As String

Dim x As Integer

woord = InputBox(“Voer een woord in van 5 letters”)

a = Mid(woord, 1, 1)

b = Mid(woord, 2, 1)

c = Mid(woord, 3, 1)

d = Mid(woord, 4, 1)

e = Mid(woord, 5, 1)

If a = e Then

If b = d Then

MsgBox “Palindroom”

Else

MsgBox ” Geen Palindroom”

End If

Else

MsgBox “Geen Palindroom”

End If

Is het een palindroom? Onbeperkt

Sub IsHetEenPalindroomOnbeperkt()

Dim a As String

Dim z As String

Dim woord As String

Dim x As Integer

Dim i As Integer

woord = InputBox(“Voer een woord in”)

x = Len(woord)

For i = 1 To x

a = Mid(woord, i, 1)

z = Mid(woord, x, 1)

x = x – 1

Next

If a = z Then

MsgBox (“palindroom”)

Else

MsgBox (“geen palindroom”)

End If

End Sub

Voeg kolom in bestand, met header en bepaal waarde van de cellen op basis van bepaald criterium

Sub IsHetAofB()

Application.ScreenUpdating = False

Dim x As Integer

Dim y As Double

Dim i As Integer

‘Om het aantal rijen in een excelbestand te tellen

y = Rows.Count

x = Cells(y, 1).End(xlUp).Row

Workbooks(1).Activate

Worksheets(“Sheet”).Select

Columns(12).Insert xlShiftToRight

Range(“L1”).Select

ActiveCell.Value = “FIELDLABEL”

ActiveCell.Offset(1, 0).Select

Do Until IsEmpty(ActiveCell.Offset(0, -1))

For i = 1 To x

If ActiveCell.Offset(0, -1) Like “*A*” Then

ActiveCell.Value = “X”

Else

ActiveCell.Value = “Y”

End If

ActiveCell.Offset(1, 0).Select

Next

Loop

End Sub

Verwijder records op basis van minima en maxima in te geven met een invoerbox

Sub SortSelectRemoveRows()

Application.ScreenUpdating = False

Sheets(“Output”).Select

Range(“a1”).CurrentRegion.Select

Dim x As Integer

Dim y As Double

Dim i As Integer

Dim Min As Integer

Dim Max As Integer

Min = InputBox(“Enter minimum”)

Max = InputBox(“Enter maximum”)

’tel het aantal rijen

y = Rows.Count

x = Cells(y, 1).End(xlUp).Row

Range(“B2”).Select

For i = 1 To x

If ActiveCell.Value < Min Or ActiveCell.Value > Max Then

Selection.EntireRow.Delete

Else

‘ Selects the next cell.

ActiveCell.Offset(1, 0).Select

End If

Next

Range(“a1″).CurrentRegion.Select

Selection.Sort Key1:=”Count”, Order1:=xlAscending, Header:=xlYes

Range(“a1:E1”).Select

Selection.Interior.Color = RGB(0, 0, 128)

With Selection.Font

.Size = 12

.Color = RGB(255, 255, 255)

.Bold = True

End With

Range(“C1”).Value = “LABELA”

Range(“D1”).Value = “LABELB”

Range(“E1”).Value = “LABELC”

End Sub

Tel het aantal gebeurtenissen op basis van een bepaald criterium

Sub CountIfFindings()

Application.ScreenUpdating = False

Dim a As String

Dim x As Integer

Dim y As Double

Dim x2 As Double

Dim y2 As Double

Dim i As Integer

Dim j As Integer

Dim CountWord As Integer

’tel aantal rijen

Worksheets(“Output”).Select

y = Rows.Count

x = Cells(y, 1).End(xlUp).Row

Worksheets(“Report1”).Select

y2 = Rows.Count

x2 = Cells(y2, 1).End(xlUp).Row

Do Until IsEmpty(ActiveCell)

For i = 1 To x

Worksheets(“Output”).Select

Cells(i + 1, 1).Select

a = (ActiveCell.Value)

For j = 1 To x2

Worksheets(“Report1”).Select

Cells(j, 4).Select

ActiveCell.Offset(1, 0).Select

If Cells(j, 12).Value Like “A” Then

If InStr(Selection, a) = 0 Then

ActiveCell.Offset(1, 0).Select

Else

CountWord = CountWord + 1

End If

End If

ActiveCell.Offset(1, 0).Select

Next

Worksheets(“Output”).Select

Cells(i + 1, 3) = CountWord

CountWord = 0

Next

Loop

Worksheets(“Report1”).Select

Range(“a1”).Select

End Sub

Wat is de tafel van…?

Sub WatIsDeTafelVan()

Dim tafel As Integer, tel As Integer

Dim antwoord As Integer, aantalCorrect As Integer

tafel = InputBox(“Welke tafel? 99 om te stoppen”)

Do While tafel <> 99

tel = 1

aantalCorrect = 0

Do While tel <= 10

antwoord = InputBox(tel & ” maal ” & tafel & ” = “)

If antwoord = tel * tafel Then

MsgBox “Prachtig”

aantalCorrect = aantalCorrect + 1

Else

MsgBox “Verkeerd”

End If

tel = tel + 1

Loop

MsgBox “Aantal correct = ” & aantalCorrect

tafel = InputBox(“Welke tafel? 99 om te stoppen”)

Loop

MsgBox “Tot ziens”

End Sub

Driehoek: Gelijk, -benig, -zijdig of willekeurig

Sub DriehoekGelijkBenigZijdigWillekeurig()

Dim a As Integer, b As Integer, c As Integer

a = InputBox(“Voer lengte van zijde a in”)

b = InputBox(“Voer lengte van zijde b in”)

c = InputBox(“Voer lengte van zijde c in”)

If a = b Then

If b = c Then

MsgBox (“gelijkzijdig”)

Else: MsgBox (“Gelijkbenig”)

End If

Else

If a = c Then

If a <> b Then

MsgBox (“gelijkbenig”)

End If

Else

If b = c Then

If a <> c Then

MsgBox (“gelijkbenig”)

End If

Else

MsgBox (“Willekeurig”)

End If

End If

End If

End Sub