VBA Scripts - ExcelStudie

Zoeken
Ga naar de inhoud

Hoofdmenu:

Modellen

VBA scripts - Handig & Oefenen

De VBA scripts bevatten vele kleine handige tooltjes die je kunt gebruiken vooral om mee te oefenen

.
Sommige kun je ook inzetten voor repeterende activiteiten waarvoor niet direct een functie voorhanden is in Excel. Denk bijvoorbeeld aan het verwijderen van lege rijen of zoeken van records op basis van bepaalde criteria of het snel ophalen van data uit een ander bestand en op de juiste plek plaatsen op basis van bepaalde kenmerken. Maar ook andere VBA scripts kun je hier vinden, zoals palindroom en - een gouwe ouwe -
het priemgetal.

VBA Scripts

Hieronder vind je diverse VBA scripts die je kunt gebruiken in je eigen Excel werkmap. Om met VBA te leren werken is het handig om even een willekeurig scriptje te testen in je werkboek, een aantal parameters te veranderen en kijken wat er dan gebeurt. In sommige sciptjes staat een verwijzing naar een kolomnummer, probeer dat eens te veranderen naar een variabele.

Als je vragen of opmerkingen hebt mail ons dan: info@excelstudie.nl. Of plaats een berichtje op onze facebookpagina. We twitteren ook!
Heb je zelf een leuk script dat je wilt delen? Stuur het naar ons toe en we plaatsen je creatie met naam en toenaam. Er wordt nog gewerkt aan een handige indeling, zodat je sneller kunt zoeken op functionaliteit.

(c) 2016 eXcelstudie

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

Sub Herhalen()
 Dim tel As Integer
 tel = 0
 Do While tel <= 5
        tel = tel + 1
        MsgBox tel
   Loop
End Sub

Sub Vermenigvuldigen()
 Dim t As String, n As Integer
  t = 4
  n = 3
  MsgBox n * t
End Sub
 
Sub Eindeloos()
   Dim t As Integer
 
   t = 20
 
       Do While t <= 20 And t > -5
 
       MsgBox t
 
       t = t - 1
 
   Loop
 
End Sub

Sub Eindeloos2()
Dim t As Integer
t = 20
       Do While t <= 20
        MsgBox t
        t = t - 1
        Loop
End Sub

Sub Optellen()
Dim x As Long, y As Long
x = 17000
y = x + x
MsgBox y
End Sub

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

Sub OkKnop()
Dim a As Integer
a = 3
MsgBox 3, vbOKOnly
End Sub

Sub NaamPlaatje()
Dim Naam As String
  Naam = InputBox("Typ je naam gevolgd door een enter", "Naamplaatje", "Piet")
  MsgBox "Hallo" + " " + Naam
End Sub

Sub Popgroep()
Dim Popgroep As String
 
   Popgroep = InputBox("Wat is jouw favoriete popgroep?", "Popgroep", "Deep Purple", , 1)
 
   MsgBox "Jouw favoriete popgroep is" + " " + Popgroep
 
End Sub

Sub DrieKnoppen()
 
Dim Yes As String
 
MsgBox "Knoppen Yes, No en Cancel op dit formulier", vbYesNoCancel + vbInformation + vbDefaultButton3
 
End Sub
 
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 workbook 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

 
Sub AntwoordJaOfNeeHerhaal()
Dim a As String
 
   Do
 
       a = InputBox("antwoord met Ja of Nee")
 
   Loop While a <> "Ja" And a <> "Nee"
 
End Sub

Sub TestInvoerGetal()
Dim a As Variant
 
   Do
 
       a = InputBox("Voer getal in")
 
   Loop While Not IsNumeric(a)
 
End Sub

Sub ForNextTotElfTellen()

Dim tel As Integer
 
   For tel = 1 To 10
 
       MsgBox tel
 
   Next tel
 
   MsgBox "Nu is tel gelijk aan " & tel
 
End Sub

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

Sub ForEachNoemWerkbladen()
Dim w As Worksheet
 
   For Each w In ActiveWorkbook.Worksheets
 
       MsgBox w.Name
 
   Next w
 
End Sub

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

                  


 
TH83 Copyright 2016 (c)
Terug naar de inhoud | Terug naar het hoofdmenu