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
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)
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 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
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
Klik in Excel op Alt + F11 om de VBA-editor te openen.
Invoegen → Module.
Plak de onderstaande code in de module.
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
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)
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.
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
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 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
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
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
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 < b then we get a large initial quotient as an extra step
If modulus > 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 > 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 < 0
xTwo = xTwo + modulus
Wend
findInverse = xTwo 'return!
End Function