Sub CalculateGCD()
    ' Euclidean Algorithm with user input
    Dim a As Long, b As Long
    Dim temp As Long
    Dim originalA As Long, originalB As Long
    
    ' Get input from user
    a = InputBox("Enter first number:", "Euclidean Algorithm")
    b = InputBox("Enter second number:", "Euclidean Algorithm")
    
    ' Store original values for display
    originalA = a
    originalB = b
    
    ' Ensure positive numbers
    a = Abs(a)
    b = Abs(b)
    
    ' Handle zero cases
    If a = 0 And b = 0 Then
        MsgBox "GCD(" & originalA & ", " & originalB & ") = 0"
        Exit Sub
    End If
    
    If a = 0 Then
        MsgBox "GCD(" & originalA & ", " & originalB & ") = " & b
        Exit Sub
    End If
    
    If b = 0 Then
        MsgBox "GCD(" & originalA & ", " & originalB & ") = " & a
        Exit Sub
    End If
    
    ' Euclidean Algorithm
    Do While b <> 0
        temp = b
        b = a Mod b
        a = temp
    Loop
    
    ' Display result
    MsgBox "GCD(" & originalA & ", " & originalB & ") = " & a
End Sub

Een listbox op een userform dynamisch filteren.

Ten eerste, sla op de toetscombo Alt+F11 om in de VBE te belanden. Voeg een  userform toe  en gooi er een textbox, een listbox en een knop op.

Ten tweede, op “Sheet2” in je werkmap zet je wat data bijvoorbeeld namen en adressen. Ik heb het mezelf gemakkelijk gemaakt en die Noordenwind database van MS gebruikt zoals je kunt zien …

Download een voorbeeld van de Noordenwind database.

Sub Filter_Listbox()
    UserForm1.Show
End Sub

Deze code voeg je in de userform module in:

Private Sub TextBox1_Change()
    With Worksheets("Sheet2")

        'Read TextBox
        strLetter = Me.TextBox1.Text

        'Clear ListBox
        Me.ListBox1.Clear

        'If filtermode is on show me all data from Sheet2
        If .FilterMode Then .ShowAllData

        'Read column A of the original list
        vList = Range("A2", Cells(Rows.Count, _
            1).End(xlUp)).Value

        'Convert it to a 1D array
        vList = Application.Transpose(vList)
        'Filter it using the Filter function,
        'available in VB6 (meaning from Excel 2000 and above).
        vList = Filter(SourceArray:=vList, Match:=strLetter, _
            Include:=True, Compare:=vbTextCompare)

        'Send it to the listbox
        Me.ListBox1.List = vList
    End With
End Sub

Private Sub UserForm_Initialize()
    With Worksheets("Sheet2")

        'Clear ListBox
        Me.ListBox1.Clear

        'If filtermode is on show me all data
        If .FilterMode Then .ShowAllData
        
        'Read column A of the original list
        'and sent it to the listbox
        'No Filtering necessary
        Me.ListBox1.List = Range("A2", Cells(Rows.Count, _
            1).End(xlUp)).Value

        'Set Focus to TextBox
        Me.TextBox1.SetFocus
    End With
End Sub

Private Sub CommandButton1_Click()
    MsgBox ListBox1.Value
    'Unload the userform
    Unload Me
End Sub

Sub Dictionary_Example()
    'Create variable
    Dim odict As Object
    Dim varKey As Variant

    'Set a reference to the Scripting.Dictionary
    Set odict = CreateObject("Scripting.Dictionary")

    'Add some keys (here, countries) and items (here, capitals)
    odict.Add "Netherlands", "Amsterdam"
    odict.Add "Germany", "Berlin"
    odict.Add "Spain", "Madrid"
    odict.Add "Norway", "Oslo"
    odict.Add "Swizerland", "Bern"
    odict.Add "France", "Paris"
    odict.Add "Bosnia and Herzegovina", "Sarajevo"
    odict.Add "Czech Republic", "Prague"
    odict.Add "Slovakia", "Bratislava"
    
    'Loop through oDict and display the info
    For Each varKey In odict.Keys()
    
        'Print to the immediate window
        Debug.Print odict(varKey)
    Next
End Sub

Sub SimpleCollection()
    '*********************************************************
    'This procedure reads the values in cell A1 and down to
    'the first empty cell and add them to a collection.
    'After that the values are written to cell C1 and down.
    '*********************************************************
    
    Dim colMyCol As New Collection 'Our collection
    Dim vElement                   'Variant to represent an element
    Dim rRange As Range            'Range variable
    Dim rCell As Range             'Range variable
    Dim lCount As Long             'Counter
    
    Set rRange = Range("A1")
    
    'If cell A1 is empty we cancel and leave the procedure.
    If Len(rRange.Value) = 0 Then GoTo BeforeExit
    
    'If there is anything in A2, we expand rRange to the last empty cell.
    If Len(rRange.Offset(1, 0).Value) > 0 Then
      Set rRange = Range(rRange, rRange.End(xlDown))
    End If
    
    'Now the cell values are added to the collection.
    'Notice that we DON'T give the items a name (key).
    For Each rCell In rRange
      colMyCol.Add rCell.Value
    Next
    
    'Now we write the values to cell C1 and down.
    'Just like a range a collection can be looped with
    'For Each...Next.
    For Each vElement In colMyCol
      Range("C1").Offset(lCount, 0).Value = vElement
      lCount = lCount + 1
    Next
BeforeExit:
    Set colMyCol = Nothing
    Set rRange = Nothing
    Set rCell = Nothing
    
    Exit Sub
ErrorHandle:
    MsgBox Err.Description & " Error in procedure SimpleCollection"
    Resume BeforeExit
End Sub

Public Function Get_Driver() As String

Const HKEY_LOCAL_MACHINE = &H80000002
Dim l_Registry As Object
Dim l_RegStr As Variant
Dim l_RegArr As Variant
Dim l_RegValue As Variant

Get_Driver = ""
Set l_Registry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
l_Registry.enumvalues HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers", l_RegStr, l_RegArr

For Each l_RegValue In l_RegStr
    If InStr(1, l_RegValue, "MySQL ODBC", vbTextCompare) > 0 Then
        Get_Driver = l_RegValue
        Exit For
    End If
Next
Set l_Registry = Nothing

End Function

Deze veelzijdige en nuttige functie vond ik in een boek genaamd: VBA Developer’s Handbook, 2nd Edition
Dus alle credits gaan naar de schrijvers Ken Getz en Mike Gilbert.

Essentiële functie wanneer je met veel tekenreeksen moet werken bijvoorbeeld postcodes of als je vaak karakters (tekens) moet vervangen binnen een tekenreeks. Ik beveel het boek aan als je zogenaamde bullet-proof vba-code moet schrijven.

Public Function dhTranslate(ByVal strIn As String, _
ByVal strMapIn As String, _
ByVal strMapOut As String, _
Optional lngCompare As VbCompareMethod = vbBinaryCompare) As String
‘ In:
‘ strIn:
‘ String in which to perform replacements
‘ strMapIn:
‘ Map of characters to find
‘ strMapOut:
‘ Map of characters to replace. If the length
‘ of this string is shorter than that of strMapIn,
‘ use the final character in the string for all
‘ subsequent matches.
‘ Example:
‘ dhTranslate(“This is a test”, “aeiou”, “AEIOU”) returns
‘ “ThIs Is A tEst”
‘ Used by:
‘ dhExtractString
‘ dhExtractCollection
‘ dhTrimAll
‘ dhCountWords
‘ dhCountTokens

Dim lngI As Long
Dim lngPos As Long
Dim strChar As String * 1
Dim strOut As String

' If there's no list of characters
' to replace, there's no point going on
' with the work in this function.
If Len(strMapIn) > 0 Then
    ' Right-fill the strMapOut set.
    If Len(strMapOut) > 0 Then
        strMapOut = Left$(strMapOut & String(Len(strMapIn), _
        Right$(strMapOut, 1)), Len(strMapIn))
    End If

    For lngI = 1 To Len(strIn)
        strChar = Mid$(strIn, lngI, 1)
        lngPos = InStr(1, strMapIn, strChar, lngCompare)
        If lngPos > 0 Then
            ' If strMapOut is empty, this doesn't fail,
            ' because Mid handles empty strings gracefully.
            strOut = strOut & Mid$(strMapOut, lngPos, 1)
        Else
            strOut = strOut & strChar
        End If
    Next lngI
End If
dhTranslate = strOut

End Function

Product information

Author	Ken Getz
Co-author	Mike Gilbert
Form	With illustration
Language	Dutch
Size	66x239x174 mm
Weight	1,67 kg
ISBN10	9041901841
ISBN13	9789041901842

© Ken Getz en Mike Gilbert

Een variant van deze functie kreeg ik van een profi van het MrExcel forum.
Credits en ©: Rick Rothstein
Dit is een zeer verkorte versie met dezelfde werking.

Function rrTranslate(ByVal strIn As String, _
ByVal strMapIn As String, _
ByVal strMapOut As String, _
Optional lngCompare As VbCompareMethod = vbBinaryCompare) As String
Dim x As Long
    For x = 1 To Len(strMapIn)
        strIn = Replace(strIn, Mid(strMapIn, x, 1), _
        Mid(strMapOut, Application.Max(1, Application.Min(x, Len(strMapOut))), 1))
    Next
    rrTranslate = strIn
End Function

Function GetURL(cell As Range, Optional default_value As Variant)
    'Lists the Hyperlink Address for a Given Cell
    'If cell does not contain a hyperlink, return default_value
    If (cell.Range("A1").Hyperlinks.Count <> 1) Then
        GetURL = default_value
    Else
        GetURL = cell.Range("A1").Hyperlinks(1).Address
    End If
End Function

Iets sneller, voor als je een hele kolom moet doen. Selecteer de kolom waarin de hyperlinks staan. Zorg wel dat je rechts van die kolom geen data hebt staan want dat bereik wordt overschreven.

Sub ExtractHL()
Dim HLink As Hyperlink

For Each HLink In Selection.Hyperlinks
    HLink.Range.Offset(0, 1).Value = HLink.Address
Next
End Sub

Je hebt een hele kolom vol met urls maar die zijn platte tekst. Zoiets:
https://www.google.nl/?gws_rd=ssl
https://www.msn.com/nl-nl/?ocid=iehp
https://subscene.com/
https://www.addic7ed.com/
Etc.
Om een hyperlink van al die urls te maken, selecteer ze allemaal en voer de macro uit.

Sub Verander_In_Hyperlinks()
Dim rngCell As Range
    For Each rngCell In Intersect(Selection, ActiveSheet.UsedRange)
        If rngCell <> "" Then
            ActiveSheet.Hyperlinks.Add rngCell, rngCell.Value
        End If
    Next
End Sub

Nu je een verbinding tot stand hebt gebracht met je MySql database kun je gegevens ophalen. Heb je nog geen verbinding, lees dan eerst dit bericht, “Connector/ODBC installeren”

Klik op: Gegevens | Van andere bronnen | MS Query

Je kiest de gegevensbron die je al eerder hebt aangemaakt in dit geval Unicode.

Let op ! ! ! Kruis het vak “Query’s maken/bewerken met behulp van de wizard query”

Er verschijnt een mededeling: “Verbinding maken met de gegevensbron”

In het volgende venster zie je de tabellen die in je database staan. In dit voorbeeld maak ik gebruik van de tabel van “Noordenwind”. Dat is een soort voorbeeldtabel van Microsoft. Onderaan zal ik kort toelichten hoe je die voorbeeldtabellen kunt installeren.

Klik op “Noordenwind” (of je eigen tabellen) en vervolgens op het “>” teken om de tabellen toe te voegen. Ze staan nu rechts in het venster. Klik op “Volgende”.

Doorloop de venster “Filteren en Sorteren”. Tenslotte voor “Weergeven in Excel” en “Voltooien”. En voilà, daar staan de gegevens.

Je kunt de gegevens nog aanpassen door in het lint te kiezen voor de tab “Hulpmiddelen voor tabellen” en vervolgens op “Eigenschappen” te klikken.

Let op ! ! ! Met de kleine knop rechts kun je nog meer instellen. Bijvoorbeeld of je de data wil bijwerken als de map opnieuw geopend wordt.

In de andere tab kun je de query veranderen mocht je dat willen.

Nog even over het importeren van de tabellen van ‘Noordenwind” of “Northwind” als je het Engels prefereert. Ik ga er van uit dat je al een database hebt en weet hoe je die moet benaderen. Bijvoorbeeld met het programma “phpmyadmin”.

Download dan hier het sql bestand

1. Pak het zip bestand uit.

2. Indien je phpmyadmin gebruikt, selecteer je je database en kiest voor importeren.

3. Klik op “Bestand kiezen” en zoek het zojuist uitgepakte sql-bestand (northwind.sql) en klik op “Start”.

4.Importeer vervolgens het bestand northwind-data.sql

Lees eerst deze berichten:

Connector/ODBC installeren
Gegevens ophalen met MySQL en importeren in Excel

Met onderstaande code kun je automatisch data lezen uit je MySQL database. Voorop gesteld dat je bovenstaande berichten hebt gelezen en uitgevoerd.

Sub SelecteerDataVanMySQL()
    
    Dim SQLStr As String
    Dim Cn As ADODB.Connection
    Dim Server_Name As String
    Dim Database_Name As String
    Dim User_ID As String
    Dim Password As String
    Dim Table As String
    Dim rs As ADODB.Recordset
    Dim rngKolom As Integer
    Dim rngRij As Integer
    Dim myArray()
    Dim K As Integer
    Dim R As Integer
    
    'Set variable
    Set rs = New ADODB.Recordset
    
    'Clear the range
    Range("a5:bb60000").ClearContents
    
    'Connection properties
    Server_Name = "YOUR SERVER NAME"
    Database_Name = "YOUR DATABASE NAME"
    User_ID = "YOUR USER ID"
    Password = "YOUR PASSWORD"
    Table = "YOUR TABLE NAME"
    Field = "YOUR FIELD NAME"

    'Create a mysql query string
    SQLStr = "SELECT * FROM " & Table & " WHERE " & Field & "  = 2"
    
    'Connect to the database
    Set Cn = New ADODB.Connection
    Cn.Open "Driver={MySQL ODBC 5.3 Unicode Driver};Server=" & _ 
        Server_Name & ";Database=" & Database_Name & ";Uid=" & _
        User_ID & ";Pwd=" & Password & ";"
    
    'Create a recordset
    rs.Open SQLStr, Cn, adOpenStatic
    
    'Store rs in array variable
    myArray = rs.GetRows()
    rngKolom = UBound(myArray, 1)
    rngRij = UBound(myArray, 2)
    For K = 0 To rngKolom
        'Transfer recordset data to worksheet
        Range("A5").Offset(0, K).Value = rs.Fields(K).Name
        For R = 0 To rngRij
            Range("A5").Offset(R + 1, K).Value = myArray(K, R)
        Next
    Next
    'Close the connection
    rs.Close
    Set rs = Nothing
    Cn.Close
    Set Cn = Nothing
End Sub

Vandaag een zogenaamde MATRIX formule die de waarde van elke n-th rij optelt.  De n staat normaal voor de onbekende. In dit voorbeeld staat de n voor de 3e rij. We gaan dus de waarde van elke 3e rij optellen.

1. De functie RIJ geeft het rijnummer van een cel.

2. De functie REST geeft de rest van een deling. Bijvoorbeeld,  REST(1;3) geeft 1, want 1:3 geeft een rest van 1. De 3e rij echter, geeft een ander resultaat, REST(3;3) geeft een rest van 0. Het resultaat van de functie REST geeft 0 voor telkens de 3e rij.

Opmerking: je kunt ook elke 4e rij of 5e rij optellen.

3. Verander de functie zoals in het onderstaande voorbeeld.

4. Je ziet nu dat elke 3e rij de waarde WAAR geeft en dat gegeven gebruiken we om de naast liggende waarden op te tellen. Om waarden op te tellen gebruik je de functie SOM. Maar we willen de formule in één cel zetten die vervolgens al het werk doet.

Selecteer daarom cel A10. Nu type je de formule zoals aangegeven. Je moet de formule invoeren als zogenaamde MATRIX. In plaats van op Enter te drukken voer je de formule in door middel van  Ctrl + Shift + Enter.

Opmerking: De formule balk geeft aan dat het hier om een MATRIX formule gaat. Dat kun je zien aan de accolades { } . Deze accolades moet je niet zelf typen want dan werkt de formule niet.

Eigenlijk ziet de MATRIX er als volgt uit. De getallen 5, 66, 21 worden dus opgeteld, met als resultaat 92.

{0;0;5;0;0;66;0;0;21}