Private Sub Commandbutton2_Click()
Dim sn, sp, arr, arr2 'delareren van alle variabelen
Dim i As Long, n As Long, j As Long, jj As Long, jjj As Long, jjjj As Long, a As Long 'declaratie
Dim Dic As Object 'idem
Dim id As String 'idem
Dim c As Range 'idem
Dim t As Single 'idem
t = Timer 'spreekt voor zich
Application.ScreenUpdating = False 'tegen flikkeren van het scherm
Set Dic = CreateObject("Scripting.Dictionary") 'dictionary aanmaken om dubbele gegevens tegen te gaan.
sn = Sheets("personen").Cells(1).CurrentRegion 'gooi alle aaneengesloten gegevens in de array "sn".
sp = Sheets("feiten").Cells(1).CurrentRegion ' idem als sn maar dan sp.
ReDim arr(1 To UBound(sn) + UBound(sp), 1 To UBound(sn, 2)) 'maak een array aan met de grootte van 1 tot de rijen van 'sn' + 'sp', en de breedte van de kolommen van 'sn'.
n = UBound(sn) + UBound(sp) 'geef 'n' de waarde van de rijen sn+sp.
For i = UBound(sn) To 1 Step -1 'van onderen naar boven de lus laten lopen.
id = sn(i, 1) & "_" & sn(i, 9) 'maak een id aan van de de gegevens uit de array (doorsnede kolom A en kolom I met de underscore als acheidingsteken).
If Not Dic.Exists(id) Then 'als het niet aanwezig is maak het aan in de volgende regel
Dic(id) = 0
For jj = UBound(sp) To 2 Step -1 'van onderen naar boven de lus laten lopen (laatste cel tot 2)
If sn(i, 1) = sp(jj, 1) And sp(jj, 18) = "ALIAS" Then 'als de rij van kolom A van blad 'personen' gelijk is aan de rij van kolom A van blad 'feiten' en de rij op kolom R = "Alias" dan
n = n - 1 'verlaag dan n minus 1
arr(n, 1) = sp(jj, 1) 'arr(waarde van n,1), wordt de waarde van sp(jj,1)
arr(n, 5) = sp(jj, 19) 'arr(waarde van n,5), wordt de waarde van sp(jj,19)
End If
Next jj
n = n - 1
For j = 1 To UBound(arr, 2) 'een lus van links naar rechts waarmee j steeds ophoogt met 1
arr(n, j) = sn(i, j) 'arr(n,j) krijgt de waarde van sn(i,j)
Next j 'volgende j tot einde
End If
Next i
ReDim arr2(1 To UBound(arr), 1 To UBound(arr, 2)) 'maak een nieuwe array met arr2
aa = UBound(arr) - n 'aa krijgt de waarde door getalletjes van elkaar af te trekken
n = 0
For jjj = UBound(arr) - aa To UBound(arr) 'nieuwe lus jjj
n = n + 1 'spreekt voor zich nu (elke keer dat j wordt verhoogt, wordt n een groter getal).
For jjjj = 1 To UBound(arr, 2) 'moet je nu wel weten
nn = nn + 1
arr2(n, nn) = arr(jjj, jjjj) 'arr2(n,nn) krijgt de waarde van arr(jjj,jjjj)
Next jjjj 'volgende jjjj
nn = 0 'maak n weer nul
Next jjj 'volgende jjj
With Sheets("test") 'alles met een punt voor elk stukje code heeft betrekking op blad "test".
.Cells(1).Resize(UBound(arr2), UBound(arr2, 2)) = arr2 'alle gegevens van de array arr2 worden weggeschreven (rijen en kolommen)
On Error Resume Next 'om geen foutmelding in de code te krijgen in volgende regelcode als er geen lege cellen zijn
.Columns(3).SpecialCells(4).Offset(, -2).Font.Color = vbBlue 'voor alle lege cellen in kolom C en dan twee kolommen naar links die tekstkleur blauw maken
End With 'einde met betrekking op tabblad 'test'.
Debug.Print Format(Timer - t, "0.0000"), "hsv 2" 'ga voor deze coderegel naar Menu Beeld > Venster direct om de snelheid uit te lezen.
Set Odic = Nothing 'de boel weer opruimen
Application.ScreenUpdating = True 'mag ook weggelaten worden trouwens (na afloop code keert scherm automatisch terug
End Sub 'einde verhaal
