Vul een matrix met het alfabet waarbij de regels telkens verspringen. Je krijgt dus als het ware een vierkant. 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
Dim x, y, z As Integer
strAlfabet = "ZABCDEFGHIJKLMNOPQRSTUVWXY"
For x = 1 To 26
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
Next
Debug.Print "OK"
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
Function Xgcd(a, b)
Dim result(3)
x = 0: y = 1: result(1) = 1: result(2) = 0: result(3) = a
Do While b > 0
temp = b
quotient = Int(result(3) / b)
b = result(3) Mod b
result(3) = temp
temp = x
x = result(1) - quotient * x
result(1) = temp
temp = y
y = result(2) - quotient * y
result(2) = temp
Loop
Xgcd = result
End Function
'Example
Sub getXgcd()
Dim xg()
xg() = Xgcd(838041641, 198491329)
Debug.Print "ax + by = gcd(838041641, 198491329)" & Chr(13) & "x is " & xg(1) & ", y is " & xg(2) & " and a is " & xg(3)
End Sub
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 …
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
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
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
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
