Cryptografie en het Vernam Cipher.

Nog een voorbeeld van het Vernam Cipher. Dat is een crypto algoritme waarmee je tekst kunt versleutel en ontsleutelen (encryption en decryption) d.m.v. een geheime Key/Sleutel. Dat kan met de code die hieronder staat.
Je hoeft geen tekst of Key in te voeren want die staat al in de code. Mag jezelf veranderen. Je moet wel opletten dat de tekst en de Key dezelfde lengte hebben. Hier een voorbeeld. In de code staat trouwens een andere tekst en Key.

Kopieer de onderstaande code middels Ctrl + C
Druk op de toetscombinatie ALT + F11 om de Visual Basic Editor te openen
Druk op de toetscombinatie ALT + N om het menu Invoegen te openen
Druk op M om een standaard module in te voegen
Daar waar de cursor knippert voeg je de code in middels Ctrl + V
Druk op de toetscombinatie ALT + Q om de Editor af te sluiten en terug te keren naar Excel
Druk op de toetscombinatie ALT + F8 om de Macro Dialoog te tonen. Dubbelklik op de macro naam XorUsage om te starten.

Option Explicit
    ' This Vernam Cipher uses the bitwise XOR operation
    ' Purpose: Encrypt and decrypt a message using the Vernam cipher with given plaintext and key, preserving spaces.
    ' Plaintext and Key(Pwd) have to be the same length
    ' Input: Plaintext and Key(Pwd) are already hardcoded in code below. Adjust if you want
    ' Output: Ciphertext in cell A2, Decrypted text in cell A3, TRUE or FALSE in cell A4.

Sub XorUsage()
    ' This Vernam Cipher uses the bitwise XOR operation
    Dim Pwd As String
    
    ' Put into A1 the text to be encrypted /decrypted
    [A1:A5].ClearContents
    
    'Plaintext and Key(Pwd) are already hardcoded in code below. Adjust if you want
    [A1].Value = UCase("DE QUERULANT BEKLAAGDE ZICH OPNIEUW OVER MIJN XYLOFOONSPEL") ' Convert to uppercase
    ' Set the password
    Pwd = UCase("UNCOPYRIGHTABLEUNCOPYRIGHTABLEUNCOPYRIGHTABLEUNCOPYRIGHTAB")   ' Convert to uppercase
    [A2].Value = Pwd
    
    If Len(Pwd) = 0 Then Exit Sub
    
    ' Put encrtypded A1 to A2
    [A4].Value = StrXor([A1].Value, Pwd)
    
    ' Put Decrypted A2 to A3
    [A5].Value = StrXor([A4].Value, Pwd)
    
    ' Compare Decrypted A3 with Original A1
    [A6].Formula = "=A1=A5"
End Sub
 
 
Function StrXor(Txt As String, Pwd As String) As String
    Dim a As Integer, b As Integer, c As Integer, i As Long, j As Long
    For i = 1 To Len(Txt)
        j = j + 1
        If j > Len(Pwd) Then j = 1
            a = Asc(Mid(Txt, i))
            If a <> 32 Then
                b = Asc(Mid(Pwd, j))
                c = a Xor b   ' <-- Encription/Decription
                c = c Xor 255 ' <-- This excludes Chr(0)
            Else
                c = 32
            End If
        StrXor = StrXor & Chr(c)
    Next
End Function

Vindt de factoren van elk getal.

in de wiskunde is het factoriseren of het ontbinden in factoren van een getal het herschrijven van dat getal in kleinere delen, die met elkaar vermenigvuldigd weer het oorspronkelijke getal opleveren. Die kleinere delen heten de factoren van het originele getal. Kun je op pen en papier doen maar het kan sneller in Excel met VBA code.

We hebben in onderstaande code 3 onderdelen verwerkt:

  • PrimeFactors (returns a formatted factorization string)
  • ListAllFactors (schrijft alle factoren op het werkblad)
  • QuickSort (sorteert de factoren van klein naar groot)
  1. Kopieer de onderstaande code middels Ctrl + C
  2. Druk op de toetscombinatie ALT + F11 om de Visual Basic Editor te openen
  3. Druk op de toetscombinatie ALT + N om het menu Invoegen te openen
  4. Druk op M om een standaard module in te voegen
  5. Daar waar de cursor knippert voeg je de code in middels Ctrl + V
  6. Druk op de toetscombinatie ALT + Q om de Editor af te sluiten en terug te keren naar Excel
  7. Druk op de toetscombinatie ALT + F8 om de Macro Dialoog te tonen. Dubbelklik op de macro naam om te starten.

In [A1] zet je een getal bijvoorbeeld: 4294967295

Vervolgens kies je voor View | Macros | View macros en klik op: ListAllFactors
om de macro te starten. Eindresultaat staat op Sheet1.

Option Explicit

' ==========================================================
' Utility Module: FactorizationTools
' Provides:
'   - PrimeFactors(number): returns prime factorization as string
'   - ListAllFactors(): lists all factors of A1 into column A
'   - QuickSort(): helper to sort factor arrays efficiently
' ==========================================================

' -----------------------------
' Returns prime factorization of number as string
' Example:  360 ? "2^3 × 3^2 × 5"
' -----------------------------
Public Function PrimeFactors(ByVal number As Double) As String
    Dim factors As String
    Dim i As Double
    Dim n As Double
    Dim cnt As Long
    
    factors = ""
    n = number
    
    ' Handle factor 2
    cnt = 0
    Do While n / 2 = Int(n / 2)
        cnt = cnt + 1
        n = n / 2
    Loop
    If cnt > 0 Then
        factors = "2"
        If cnt > 1 Then factors = factors & "^" & cnt
    End If
    
    ' Trial divide by odd numbers up to sqrt(n)
    i = 3
    Do While i * i <= n
        cnt = 0
        Do While n / i = Int(n / i)
            cnt = cnt + 1
            n = n / i
        Loop
        If cnt > 0 Then
            If factors <> "" Then factors = factors & " × "
            factors = factors & i
            If cnt > 1 Then factors = factors & "^" & cnt
        End If
        i = i + 2
    Loop
    
    ' If remainder > 1 it's a prime
    If n > 1 Then
        If factors <> "" Then factors = factors & " × "
        factors = factors & n
    End If
    
    PrimeFactors = factors
End Function

' -----------------------------
' QuickSort implementation for Double arrays
' -----------------------------
Public Sub QuickSort(arr() As Double, ByVal first As Long, ByVal last As Long)
    Dim low As Long, high As Long
    Dim pivot As Double, tmp As Double
    
    low = first
    high = last
    pivot = arr((first + last) \ 2)
    
    Do While low <= high
        Do While arr(low) < pivot
            low = low + 1
        Loop
        Do While arr(high) > pivot
            high = high - 1
        Loop
        If low <= high Then
            tmp = arr(low)
            arr(low) = arr(high)
            arr(high) = tmp
            low = low + 1
            high = high - 1
        End If
    Loop
    
    If first < high Then QuickSort arr, first, high
    If low < last Then QuickSort arr, low, last
End Sub

' -----------------------------
' Lists all factors of number in A1
'   - Outputs factors in col A starting A3
'   - Shows prime factorization in B1
'   - Shows total factor count in B2
' -----------------------------
Public Sub ListAllFactors()
    Dim num As Double
    Dim i As Double
    Dim factorCount As Long
    Dim factors() As Double
    Dim sqrNum As Double
    
    ' Read number from A1
    num = Range("A1").Value
    If num < 1 Or num > 1E+15 Then
        MsgBox "Number must be between 1 and 1,000,000,000,000,000"
        Exit Sub
    End If
    
    sqrNum = Sqr(num)
    
    ' Count factors
    factorCount = 0
    For i = 1 To sqrNum
        If num / i = Int(num / i) Then
            factorCount = factorCount + 1
            If i <> num / i Then factorCount = factorCount + 1
        End If
    Next i
    
    ReDim factors(1 To factorCount)
    
    ' Store factors
    factorCount = 0
    For i = 1 To sqrNum
        If num / i = Int(num / i) Then
            factorCount = factorCount + 1
            factors(factorCount) = i
            If i <> num / i Then
                factorCount = factorCount + 1
                factors(factorCount) = num / i
            End If
        End If
    Next i
    
    ' Sort
    If factorCount > 1 Then QuickSort factors, 1, factorCount
    
    ' Output
    Range("A3:A10000").ClearContents
    For i = 1 To factorCount
        Range("A" & (i + 2)).Value = factors(i)
    Next i
    
    ' Prime factorization & summary
    Range("B1").Value = PrimeFactors(num)
    Range("B2").Value = "Total Factors: " & factorCount
End Sub

Encryptie en decryptie met Vigenère-vierkant

Hier is een kant-en-klare VBA-macro die een volledig Vigenère-vierkant in je werkmap bouwt met de cel linksboven op A1 (A1 leeg gelaten, kolomkoppen A→Z in B1 :AA1 en rijkoppen A→Z in A2 :A27 , tabel in B2 :AA27 ).

Hoe te gebruiken

  1. Klik in Excel op Alt + F11 om de VBA-editor te openen.
  2. Invoegen → Module.
  3. Plak de onderstaande code in de module.
  4. Sluit de editor en voer de macro uit CreateVigenereSquare (je kunt op de knop drukken Alt+F8 en de macro uitvoeren).
Option Explicit

Sub CreateVigenereSquare()
    Dim ws As Worksheet
    Dim i As Long, j As Long
    Dim letter As String
    
    ' Use the active sheet (or set: Set ws = ThisWorkbook.Worksheets("Sheet1"))
    Set ws = ActiveSheet
    
    Application.ScreenUpdating = False
    
    ' Clear an area big enough (A1:AA27)
    ws.Range("A1:AA27").Clear
    
    ' Put column headers A..Z in B1:AA1 and row headers A..Z in A2:A27
    For j = 0 To 25
        ws.Cells(1, j + 2).Value = Chr(65 + j)     ' B1..AA1
        ws.Cells(j + 2, 1).Value = Chr(65 + j)     ' A2..A27
    Next j
    
    ' Fill the 26x26 Vigenère table starting at B2
    For i = 0 To 25        ' row offset (0 = A)
        For j = 0 To 25    ' column offset (0 = A)
            letter = Chr(((i + j) Mod 26) + 65)
            ws.Cells(i + 2, j + 2).Value = letter
        Next j
    Next i
    
    ' Formatting: bold headers, center text, borders, autofit
    With ws.Range("A1:AA27")
        .Font.Name = "Calibri"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    
    ws.Range("B1:AA1").Font.Bold = True
    ws.Range("A2:A27").Font.Bold = True
    
    ' Add thin borders around the square (headers + table)
    With ws.Range("A1:AA27").Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    
    ' Make cells square-ish and readable
    ws.Range("A1:AA27").Columns.AutoFit
    Dim c As Range
    For Each c In ws.Range("A1:AA27").Columns
        c.ColumnWidth = Application.Max(3, c.ColumnWidth) ' ensure not too narrow
    Next c
    
    ' Freeze panes to keep headers visible (freeze below row1 and right of colA)
    ws.Activate
    ws.Range("B2").Select
    ActiveWindow.FreezePanes = True
    
    Application.ScreenUpdating = True
    
    MsgBox "Vigenère square created at A1 (headers in row1/colA).", vbInformation
End Sub



' === Utility functions ===
Private Function CleanText(ByVal s As String) As String
    Dim i As Long, ch As String, outStr As String
    outStr = ""
    s = UCase(s)
    For i = 1 To Len(s)
        ch = Mid(s, i, 1)
        If ch >= "A" And ch <= "Z" Then
            outStr = outStr & ch
        End If
    Next i
    CleanText = outStr
End Function

Private Function FiveBlocks(ByVal s As String) As String
    Dim i As Long, outStr As String
    outStr = ""
    For i = 1 To Len(s)
        outStr = outStr & Mid(s, i, 1)
        If i Mod 5 = 0 And i < Len(s) Then
            outStr = outStr & " "
        End If
    Next i
    FiveBlocks = outStr
End Function

' === ENCRYPT USING TABLE ===
Sub VigenereEncryptTable()
    Dim ws As Worksheet
    Dim plain As String, key As String, cipher As String
    Dim i As Long, pChar As String, kChar As String
    Dim rowNum As Long, colNum As Long
    Dim keyLen As Long
    
    Set ws = ActiveSheet
    
    plain = CleanText(ws.Range("AD1").Value)
    key = CleanText(ws.Range("AD2").Value)
    keyLen = Len(key)
    cipher = ""
    
    For i = 1 To Len(plain)
        pChar = Mid(plain, i, 1)
        kChar = Mid(key, ((i - 1) Mod keyLen) + 1, 1)
        
        ' Find row for plaintext letter (in col A, rows 2:27)
        rowNum = Application.Match(pChar, ws.Range("A2:A27"), 0) + 1  ' offset +1 because Match is relative
        
        ' Find col for key letter (in row 1, cols B:AA)
        colNum = Application.Match(kChar, ws.Range("B1:AA1"), 0) + 1
        
        ' Get intersection
        cipher = cipher & ws.Cells(rowNum, colNum).Value
    Next i
    
    ws.Range("AD3").Value = FiveBlocks(cipher)
    MsgBox "Encryption complete using Vigenère square.", vbInformation
End Sub

' === DECRYPT USING TABLE ===
Sub VigenereDecryptTable()
    Dim ws As Worksheet
    Dim cipher As String, key As String, plain As String
    Dim i As Long, cChar As String, kChar As String
    Dim colNum As Long, rowNum As Long
    Dim keyLen As Long
    Dim rng As Range, f As Variant
    
    Set ws = ActiveSheet
    
    cipher = CleanText(ws.Range("AD5").Value)
    key = CleanText(ws.Range("AD6").Value)
    keyLen = Len(key)
    plain = ""
    
    For i = 1 To Len(cipher)
        cChar = Mid(cipher, i, 1)
        kChar = Mid(key, ((i - 1) Mod keyLen) + 1, 1)
        
        ' Find col for key letter
        colNum = Application.Match(kChar, ws.Range("B1:AA1"), 0) + 1
        
        ' Look in that column (rows 2:27) for ciphertext letter
        Set rng = ws.Range(ws.Cells(2, colNum), ws.Cells(27, colNum))
        f = Application.Match(cChar, rng, 0)
        
        If IsError(f) Then
            plain = plain & "?"
        Else
            rowNum = f + 1
            ' Row header in col A
            plain = plain & ws.Cells(rowNum, 1).Value
        End If
    Next i
    
    ws.Range("AD7").Value = FiveBlocks(plain)
    MsgBox "Decryption complete using Vigenère square.", vbInformation
End Sub

Opstelling gemaakt in Excel 2016.
AD1 PlainText: THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG
AD2 Key: LANDBOUWGESCHRIFT
AD3 Ciphertext

AD5 Ciphertext
AD6 Key: LANDBOUWGESCHRIFT
AD7 PlainText: comes here automatically

Het vierkant is ingedeeld zoals hierboven beschreven (A1 leeg gelaten, kolomkoppen A→Z in B1:AA1 en rijkoppen A→Z in A2:A27, tabel in B2:AA27).
Criterium voor het versleutelen: houd er in de code rekening mee dat je de traditie volgt door alle spaties en leestekens te verwijderen, alle letters naar hoofdletters te converteren en het resultaat in blokken van 5 letters te verdelen.

Hoe het werkt het nou?

  • AD1 → Invoer plaintext ( THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG)
  • AD2 → Key: ( LANDBOUWGESCHRIFT) zonder haakjes
  • Uitvoeren: VigenereEncryptTable→ resulteert in AD3 (cijfer, blokken van 5 letters).
  • Kopieer/plak AD3 in AD5 (cijfertekst om te testen).
  • AD6 → Key: ( LANDBOUWGESCHRIFT) zonder haakjes
  • Uitvoeren → VigenereDecryptTable resultaat in AD7 (plaintext, gegroepeerd).

Het kan trouwens ook zonder het vierkant door gebruik van ASCII. De ASC() functie converteert een teken naar het bijbehorende ASCII-codenummer, terwijl de 
CHR() functie het tegenovergestelde doet: een ASCII-nummer terug converteren naar de bijbehorende tekenweergave. Bijvoorbeeld:
ASC("A") zou retourneren 65 en  CHR(65)zou retourneren "A". Maar hier gebruiken we het vierkant

Eenvoudig voorbeeld SUMPRODUCT

Anders dan de naam doet vermoeden gaan we bij het gebruik van SUMPRODUCT eerst vermenigvuldigen en dan pas optellen. Hieronder vind je een lijst met films uit 2018 en wat bijzonderheden in de diverse kolommen. We willen a.d.h.v. een aantal criteria de juiste resultaten filteren en de bruto inkomsten berekenen. Criteria zijn:
– De distributor is 20th Century Fox
– Genre is Action
– TicketsSold is meer dan 30.000.000 (30 miljoen)

In het bereik B15:B17 plaatsen we de criteria en in B19 komt de formule.

Formule:

In [B19] =SUMPRODUCT(($C$3:$C$12=$B$15)*($D$3:$D$12=$B$16)*($F$3:$F$12>$B$17)*$E$3:$E$12)

Dit resulteert in een reeks TRUE en FALSE:

{FALSE;FALSE;FALSE;FALSE;TRUE;FALSE;FALSE;FALSE;FALSE;FALSE}
{TRUE;TRUE;FALSE;TRUE;TRUE;FALSE;FALSE;TRUE;TRUE;FALSE}
{TRUE;TRUE;TRUE;TRUE;TRUE;FALSE;FALSE;FALSE;FALSE;FALSE}

zoals je weet resulteert:
TRUE in 1
en
FALSE in 0

En dan krijg je:
{0;0;0;0;1;0;0;0;0;0}
{1;1;0;1;1;0;0;1;1;0}
{1;1;1;1;1;0;0;0;0;0}

Dan gaan we vermenigvuldigen. Je ziet dat er maar 1 combinatie is met drie enen (1*1*1) = 1 (rode gedeelte) en die correspondeert met de 5e waarde namelijk 324512774 en dat is tegelijk het eindresultaat omdat we geen verdere waarden hoeven op te tellen.

{700059566;678815482;608581744;417719760;324512774;269622130;235506359;220159104;216648740;213767512}

Verander je de Distributor in Walt Disney dan krijg je:
{1;1;0;0;0;0;0;0;1;1}
{1;1;0;1;1;0;0;1;1;0}
{1;1;1;1;1;0;0;0;0;0}

We gaan weer eerst vermenigvuldigen. Je ziet dat er nu 2 combinatie zijn met drie enen (1*1*1) = 1 (rode gedeelte) en die corresponderen met de 1e waarde en 2e waarde. Die tellen we op en krijgen als resultaat 1.378.875.048

{700059566;678815482;608581744;417719760;324512774;269622130;235506359;220159104;216648740;213767512}

Hoe plaats je een verwijzing naar een bibliotheek

Als je met Visual Basic for Applications werkt, kun je verwijzingen instellen naar andere, zogenaamde, bibliotheken. Dit zijn geen boeken maar een soort van kleine programma’s. Indien je nog niet in de Visual Basic Editor bent, druk je op Alt+F11.
Vervolgens op Tools | References. Je krijgt dan een menu waarin je talloze bibliotheken ziet zoals:

– Microsoft Scripting Runtime
– Microsoft Internet Controls
– Microsoft HTML Object Library
– Microsoft XLM, v6.0

Hoe vaak komt dat woord voor?

Hoe vaak komt een woord voor in een tekst? Ik zou niet weten waarom je dat zou willen weten. Maar met Excel kun je zoiets berekenen.
In afbeelding 1 zie je in Cel A1 en A2 een paar zinnen uit de welbekende  Lorem Ipsum tekst.

AFBEELDING 1

In Afbeelding 2 zie je een gedeelte van het resultaat.

AFBEELDING 2

De VBA code die je kunt gebruiken.
LET OP, de eerste code is hoofdletter gevoelig. Dat betekent dat bijvoorbeeld het woord “nulla” anders is als het woord “Nulla”. Beide woorden komen daarom 2x voor.

Option Explicit

Sub Hoe_Vaak_Komt_Dat_Woord_Voor()
'Zet Data in meerdere cellen van Kolom A.
'Data alleen in A1 geeft foutmelding
'Data in Kolom A, resultaat komt in de Kolommen C:D.

Dim x As Long, Cnt As Long, Txt As String, Arr() As String
    Txt = " " & Join(Application.Transpose(Range([A1], Cells(Rows.Count, "A").End(xlUp)))) & " "
    
    For x = 2 To Len(Txt)
        If Mid(Txt, x, 1) = "'" And Not Mid(Txt, x - 1, 3) Like "[A-Za-z0-9]'[A-Za-z0-9]" Then
            Mid(Txt, x) = " "
        ElseIf Mid(Txt, x, 1) Like "[!A-Za-z0-9']" Then
            Mid(Txt, x) = " "
        End If
    Next
    
    Arr = Split(Application.Trim(Txt))
    
    With CreateObject("scripting.dictionary")
        
        For x = 0 To UBound(Arr)
            .Item(Arr(x)) = .Item(Arr(x)) + 1
        Next
        
        Cnt = .Count
        Range("C2").Resize(Cnt) = Application.Transpose(.Keys)
        Range("D2").Resize(Cnt) = Application.Transpose(.items)
    End With
    
    Range("C2:D" & Cnt).Sort Range("C2"), xlAscending, Range("D2"), , xlDescending, Header:=xlNo, MatchCase:=False
End Sub

LET OP, de tweede code is NIET hoofdletter gevoelig. Dat betekent dat bijvoorbeeld het woord “nulla” hetzelfde is als het woord “Nulla” en daarom 4x voor komt.

Sub Hoe_Vaak_Komt_Dat_Woord_Voor_Met_RegExp()
'Data in Kolom A, resultaat komt in de Kolommen F:G.
'*****************************************************
'Geef een verwijzing op naar:
'Microsoft Forms 2.0 Object Library
'Te bereiken via: Alt+F11 | Tools | References
'*****************************************************

Dim regEx As Object, matches As Object, x As Object, d As Object
Dim obj As New DataObject
Dim tx As String, z As String

    Range("A1", Cells(Rows.Count, "A").End(xlUp)).Copy
    obj.GetFromClipboard
    tx = obj.GetText
    Application.CutCopyMode = False
    tx = Replace(tx, "'", "___")
        
    Set regEx = CreateObject("VBScript.RegExp")
    
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "\w+"
    End With
    
    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = vbTextCompare
        
    Set matches = regEx.Execute(tx)
            
        For Each x In matches
            z = CStr(x)
            If Not d.Exists(z) Then
                d(z) = 1
            Else
                d(z) = d(z) + 1
            End If
        Next
                    
    If d.Count = 0 Then MsgBox "Nothing found": Exit Sub
    Range("D:E").ClearContents
    
    'put the result in col D:E
        With Range("F2").Resize(d.Count, 2)
            .Cells = Application.Transpose(Array(d.Keys, d.items))
            .Replace What:="___", Replacement:="'", LookAt:=xlPart, SearchFormat:=False, ReplaceFormat:=False
        End With
    'Sort
    Range("F2:G" & d.Count).Sort Range("F2"), xlAscending, Range("G2"), , xlDescending, Header:=xlNo, MatchCase:=False
End Sub

Vind de hoogste waarde van een bedrijf

In Kolom A staan bedrijven. Sommige bedrijven staan er meerdere keren in. We hebben dus te maken met dubbele waarden in kolom A

We willen in dit voorbeeld de HOOGSTE waarde van Hasbro, Inc.
In D2 kun je een validatielijst maken met alle namen van de bedrijven zodat je gemakkelijk een bedrijf kunt selecteren.

Om dat te doen maak je ergens op je werkblad eerst een unieke lijst met alle bedrijven, Bijvoorbeeld in F2:F14.

Data | Data validation | Data validation | Allow > List | Source > en verwijs naar F2:F14

In [D5] =MAX(INDEX((A2:A21=D2)*B2:B21;0))

Alle hyperlinks, afbeeldingen, vormen verwijderen

Alle hyperlinks op je werkblad verwijderen. Selecteer het bereik met links en zet de code aan het werk.

Sub DeleteHyperlinks()
    With Selection
        .Hyperlinks.Delete
    End With
End Sub

Deze code verwijdert zonder pardon ALLE hyperlinks op je actieve blad.

Sub NoLinks()
    ActiveSheet.Hyperlinks.Delete
End Sub

En deze verwijdert zonder te vragen ALLE afbeeldingen.

Sub NoPictures()
    ActiveSheet.Pictures.Delete
End Sub

Deze werkt iets anders maar verwijdert toch ALLE vormen op het actieve blad.

Sub NoShapes()
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
End Sub

Vul een vierkant met het alfabet waarbij de regels telkens verspringen

Vul een vierkant met het alfabet waarbij de regels telkens verspringen. In verkorte vorm:

ABCD
BCDA
CDAB
DABC

Maar dan met alle 26 letters.

Sub Fill_Square_With_Alfabet()
Dim strAlfabet As String
Dim Arr(1 To 26, 1 To 26) As Variant

    strAlfabet = "ZABCDEFGHIJKLMNOPQRSTUVWXY"

    For intRow = 1 To 26
        strCharacter = Left(strAlfabet, 1)
        strAlfabet = Mid(strAlfabet, 2, 25) & strCharacter
        For intColumn = 1 To 26
            Arr(intRow, intColumn) = Mid(strAlfabet, intColumn, 1)
        Next
    Next



    For intRow = 1 To 26
        For intColumn = 1 To 26
            Cells(intRow, intColumn).Value = Arr(intRow, intColumn)
        Next
    Next
    
MsgBox "Square created"
End Sub

Het omgekeerde Euclidisch algoritme

Function findInverse(m As Integer, modulus As Integer) As Variant
    Dim i As Integer
    Dim xOne As Integer
    Dim xTwo As Integer
    Dim temp As Integer
    Dim remainder As Integer
    Dim divisor As Integer
    Dim dividend As Integer
    Dim allQuotients() As Integer
    
    '-----Calculate the GCD and quotients
    'The expression a = b * q + r will become
    'dividand = divisor * q + remainder
    
    dividend = m
    divisor = modulus

    'need to swap for this one because the number of quotients matters;
    'if a &lt; b then we get a large initial quotient as an extra step
    If modulus &gt; m Then
        dividend = modulus
        divisor = m
    End If
    
    ReDim allQuotients(0 To (dividend - 1)) 'resize the array
    remainder = dividend 'arbitrary initialization
    i = 0

    '---Loop go get quotients
    Do While remainder &gt; 1
        'calculate new q and r
        remainder = dividend Mod divisor
        allQuotients(i) = dividend \ divisor
        i = i + 1
        'Shift over b and r to replace a and b
        dividend = divisor
        divisor = remainder
    Loop
    
    '-----If the GCD is not 1, then the inverse is not defined.
    If Not (remainder = 1) Then
        findInverse = "No Inverse"
        Exit Function
    End If
    
    ReDim Preserve allQuotients(0 To (i - 1)) 'cut off unused elements
    
    '-----Calculate the Inverse using the quotients obtained
    'Extended euclidian algorithm with block method
    'Uses only the second row.
    '    |(quotients q1, q2, ...)
    '----------
    '0 1 | 0 - 1 * q1 | 1 - (0 - 1 * q1) * q2 |...
    
    xOne = 0
    xTwo = 1
    temp = 0 'arbitrary initialisation
    
    '---Loop for the calculation of the inverse via block
    For i = 0 To UBound(allQuotients)
        temp = xOne - (xTwo * allQuotients(i))
        xOne = xTwo
        xTwo = temp
    Next i
    
    '-----Make sure the inverse is between zero and the modulus
    While xTwo &lt; 0
        xTwo = xTwo + modulus
    Wend
    
    findInverse = xTwo 'return!
End Function