Oorspronkelijk geplaatst op 26 april 2014

Soms krijg je een data bestand waar veel fouten in zitten. Indien dat maar 20 rijen zijn kun je dat handmatig bijwerken. Maar als het tienduizend rijen zijn wordt dat een tijdrovend karwei. Vooral als er veel dubbele waarden in voorkomen.

Opzet van het blad is simpel. 

Kolom A: Originele tekst
Kolom B: De te zoeken tekst
Kolom C: De vervangende tekst
Kolom D: Nog niks, want hier komt de verbeterde tekst

Het enige waar je op moet letten is dat je de data in kolom B en C laat voorafgaan én eindigen met een spatie. Dat is niet zo moeilijk als je eerst even 2 hulpkolommen F en G maakt met de volgende formules die je doorvoert naar beneden.

F2=” ” & B2 & ” “
G2=” ” & C2 & ” “

Vervolgens die 2 kolommen kopiëren naar B en C en kiezen voor “Waarden Plakken” anders krijg je daar formules te staan en dat moet niet. Tenslotte onderstaande code in een module gooien en gaan met die banaan. Het enige tijdrovende is wellicht het opstellen van de 2 lijsten met de te zoeken en de te vervangen waarden. Dat weegt echter niet op tegen de tijdwinst die je behaalt als je alles handmatig zou moeten gaan corrigeren.

Sub Zoek_En_Vervang()
    Dim arrZoek As Variant
    Dim arrVervang As Variant
    Dim arrOrigineel As Variant
    Dim i, u As Long
    
    'Originele lijst met artikelen
    arrOrigineel = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
    
    'De te zoeken waarden
    arrZoek = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Value
    
    'De vervangende waarden
    arrVervang = Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row).Value
    
    'De zoek en vervang actie
    For i = LBound(arrOrigineel, 1) To UBound(arrOrigineel, 1)
        For u = LBound(arrZoek, 1) To UBound(arrZoek, 1)
            arrOrigineel(i, 1) = Trim(Replace _
            (" " & arrOrigineel(i, 1) & " ", _
            arrZoek(u, 1), arrVervang(u, 1), , , vbTextCompare))
        Next
    Next
    
    'Resultaten in kolom D plaatsen
    Range("D2").Resize(UBound(arrOrigineel, 1)).Value = arrOrigineel
End Sub

Sub Zoek_En_Vervang()
    Dim arrZoek As Variant
    Dim arrVervang As Variant
    Dim arrOrigineel As Variant
    Dim i, u As Long
    
    'Originele lijst met artikelen
    arrOrigineel = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
    
    'De te zoeken waarden
    arrZoek = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Value
    
    'De vervangende waarden
    arrVervang = Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row).Value
    
    'De zoek en vervang actie
    For i = LBound(arrOrigineel, 1) To UBound(arrOrigineel, 1)
        For u = LBound(arrZoek, 1) To UBound(arrZoek, 1)
            arrOrigineel(i, 1) = Trim(Replace _
            (" " & arrOrigineel(i, 1) & " ", _
            arrZoek(u, 1), arrVervang(u, 1), , , vbTextCompare))
        Next
    Next
    
    'Resultaten in kolom D plaatsen
    Range("D2").Resize(UBound(arrOrigineel, 1)).Value = arrOrigineel
End Sub

Oorspronkelijk geplaatst op 26 april 2014

Een voorbeeld van de “Like” operator. Met deze operator kun je twee tekenreeksen met elkaar vergelijken op basis van patronen die je invoert.

? staat voor één willekeurig teken
* staat voor nul of meer tekens
# staat voor één willekeurig getal (0-9)
[tekenlijst] staat voor één willekeurig teken dat in de tekenlijst voorkomt
[!tekenlijst] staat voor één willekeurig teken dat NIET in de tekenlijst voorkomt
Let op het uitroepteken
Spatie staat voor een spatie.

Voorbeeld postcode check:

Sub Is_Dit_Een_Postcode()
strTemp = "1012 NX"
If strTemp Like "####[A-Z][A-Z]" Or _
    strTemp Like "#### [A-Z][A-Z]" Or _
    strTemp Like "####  [A-Z][A-Z]" Then
    Debug.Print "Dit is een geldige postcode"
Else
    Debug.Print "Dit is GEEN geldige postcode"
End If
End Sub

Sub Is_Dit_Een_Postcode()
strTemp = "1012 NX"
If strTemp Like "####[A-Z][A-Z]" Or _
    strTemp Like "#### [A-Z][A-Z]" Or _
    strTemp Like "####  [A-Z][A-Z]" Then
    Debug.Print "Dit is een geldige postcode"
Else
    Debug.Print "Dit is GEEN geldige postcode"
End If
End Sub

Sub Is_Dit_Een_BIC_code()
strBIC = "UNCRIT2B912"
If strBIC Like _
    "[A-Z][A-Z][A-Z][A-Z][A-Z][A-Z][A-Z0-9][A-Z0-9]" Or _
    strBIC Like _
    "[A-Z][A-Z][A-Z][A-Z][A-Z][A-Z][A-Z0-9][A-Z0-9][A-Z0-9][A-Z0-9][A-Z0-9]" Then
    Debug.Print "Dit is een geldige BIC code"
Else
    Debug.Print "Dit is GEEN geldige BIC code"
End If
End Sub

Sub Is_Dit_Een_BIC_code()
strBIC = "UNCRIT2B912"
If strBIC Like _
    "[A-Z][A-Z][A-Z][A-Z][A-Z][A-Z][A-Z0-9][A-Z0-9]" Or _
    strBIC Like _
    "[A-Z][A-Z][A-Z][A-Z][A-Z][A-Z][A-Z0-9][A-Z0-9][A-Z0-9][A-Z0-9][A-Z0-9]" Then
    Debug.Print "Dit is een geldige BIC code"
Else
    Debug.Print "Dit is GEEN geldige BIC code"
End If
End Sub

Oorspronkelijk geplaatst op 26 april 2014

Onderstaande code bevat 2 code blokken om te controleren of een URL een verwijzing is naar een afbeelding: “GetURLStatus” om de status van de URL te verkrijgen c.q. of het om een afbeelding gaat en “ValidateURLs” om elke URL in kolom “F” te doorlopen. Te beginnen bij cel “F2”. Nieuwe module in je werkboek opnemen middels Alt+F11 en kiezen voor Invoegen | Module en dan de code plakken.

Code “ValidateURLs” uitvoeren. Indien het om een ongeldige verwijzing gaat (dus geen afbeelding), komt er een foutbeschrijving in kolom “D” te staan. Je kunt eventueel ook nog de bron van de pagina laten afdrukken in het Direct(immediate) venster te bereiken via Beeld | Venster direct.

' Written: April 29, 2012
' Author:  Leith Ross
' Summary: Returns the status for a URL along with the Page Source HTML text.

Public PageSource As String
Public httpRequest As Object

Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)

    Const WinHttpRequestOption_EnableRedirects = 6

    If httpRequest Is Nothing Then
        On Error Resume Next
        Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        If httpRequest Is Nothing Then
            Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
        End If
        Err.Clear
        On Error GoTo 0
    End If

    'Control if the URL being queried is allowed to redirect.
    httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects

    'Clear any pervious web page source information
    PageSource = ""

    'Add protocol if missing
    If InStr(1, URL, "://") = 0 Then
        URL = "https://" & URL
    End If

    'Launch the HTTP httpRequest synchronously
    On Error Resume Next
    httpRequest.Open "GET", URL, False
    If Err.Number <> 0 Then
        'Handle connection errors
        GetURLStatus = Err.Description
        Err.Clear
        Exit Function
    End If
    On Error GoTo 0

    'Send the http httpRequest for server status
    On Error Resume Next
    httpRequest.Send
    httpRequest.WaitForResponse
    If Err.Number <> 0 Then
        'Handle server errors
        PageSource = "Error"
        GetURLStatus = Err.Description
        Err.Clear
    Else
        'Show HTTP response info
        GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText
        'Save the web page text
        PageSource = httpRequest.ResponseText
        'You can print PageSource to immediate window
        'Debug.Print PageSource
    End If
    On Error GoTo 0
End Function

Sub ValidateURLs()

    Dim Cell As Range
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Status As String
    Dim Wks As Worksheet

    Set Wks = ActiveSheet
    Set Rng = Wks.Range("F2")

    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)

        For Each Cell In Rng
            Status = GetURLStatus(Cell)
            If Status <> "200 - OK" Then
                Cell.Offset(0, -2) = Status
            End If
        Next Cell

End Sub

' Written: April 29, 2012
' Author:  Leith Ross
' Summary: Returns the status for a URL along with the Page Source HTML text.

Public PageSource As String
Public httpRequest As Object

Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)

    Const WinHttpRequestOption_EnableRedirects = 6

    If httpRequest Is Nothing Then
        On Error Resume Next
        Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        If httpRequest Is Nothing Then
            Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
        End If
        Err.Clear
        On Error GoTo 0
    End If

    'Control if the URL being queried is allowed to redirect.
    httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects

    'Clear any pervious web page source information
    PageSource = ""

    'Add protocol if missing
    If InStr(1, URL, "://") = 0 Then
        URL = "https://" & URL
    End If

    'Launch the HTTP httpRequest synchronously
    On Error Resume Next
    httpRequest.Open "GET", URL, False
    If Err.Number <> 0 Then
        'Handle connection errors
        GetURLStatus = Err.Description
        Err.Clear
        Exit Function
    End If
    On Error GoTo 0

    'Send the http httpRequest for server status
    On Error Resume Next
    httpRequest.Send
    httpRequest.WaitForResponse
    If Err.Number <> 0 Then
        'Handle server errors
        PageSource = "Error"
        GetURLStatus = Err.Description
        Err.Clear
    Else
        'Show HTTP response info
        GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText
        'Save the web page text
        PageSource = httpRequest.ResponseText
        'You can print PageSource to immediate window
        'Debug.Print PageSource
    End If
    On Error GoTo 0
End Function

Sub ValidateURLs()

    Dim Cell As Range
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Status As String
    Dim Wks As Worksheet

    Set Wks = ActiveSheet
    Set Rng = Wks.Range("F2")

    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)

        For Each Cell In Rng
            Status = GetURLStatus(Cell)
            If Status <> "200 - OK" Then
                Cell.Offset(0, -2) = Status
            End If
        Next Cell

End Sub

Credits & © : Leith Ross

Oorspronkelijk geplaatst op 26 april 2014

Onlangs kreeg ik een werkblad toegestuurd met een vreemd datumformaat:
Okt 4th 2002 03:50 PM
Het werd door Excel als tekst gezien.
Om het te converteren naar een geldig datumformaat gebruikte ik deze formule.
De =ALS constructie is nodig om te bepalen of de dag uit 1 of 2 cijfers bestaat. Bijvoorbeeld 4th of 14th.
Let op ! ! ! Zet de celeigenschap op het goede formaat én de formule moest ik splisen wegens layout problemen. Alles aan elkaar dus

=TEKST(ALS(VIND.ALLES(” “;A1;5)-VIND.ALLES(” “;A1;1)= 4;DEEL(A1;5;1);DEEL(A1;5;2))&LINKS(A1;3)&RECHTS(A1;11);”dd-mmm-jjjj uu:mm”)

Oorspronkelijk geplaatst op: 3 mei 2014

Soms wil je de celadressen  (bijvoorbeeld $D$2) weten waarin de naam van een item of tekenreeks voorkomt. Zie afbeelding voor de opzet.

Kolom A: Stad
Kolom B: Land
Kolom C: Adres

Nu wil je weten in welke celadressen het land Italy voorkomt.

In F2 komt de formule:

=ALS.FOUT(CEL(“adres”;INDEX($B$2:$B$94;KLEINSTE(ALS(ISGETAL(
VIND.ALLES(” “&F$1&” “;” “&$B$2:$B$94&” “));
RIJ($B$2:$B$94)-RIJ($B$2)+1);RIJEN($F$2:F2))));””)

Let op ! ! ! Dit is een Matrixformule en MOET ingevoerd worden met Ctrl+Shift+Enter dus NIET met ENTER.

Vervolgens formule naar beneden kopiëren bijvoorbeeld van F3 tot F10.

Om het gemakkelijk te maken heb ik in kolom H een lijst opgenomen met alle landennamen die voorkomen. Die lijst is met behulp van gegevensvalidatie gekoppeld aan cel F1. Onderstaand venster kun je bereiken d.m.v. 

Gegevens | Gegevensvalidatie | Instellingen

Bij “Toestaan” kies je voor “Lijst” en bij “Bron” geef je het bereik op dus: $H$2:$H$20

Oorspronkelijk geplaatst op: 3 mei 2014

Door het toepassen van voorwaardelijke opmaak kun je snel verschillen opmerken in een bereik met waarden. Wat moet je doen?

Selecteer de gegevens waarop je voorwaardelijke opmaak wil toepassen.

Vervolgens klik je op:
Voorwaardelijke opmaak | Markeerregels voor cellen | Tekst met

In het onderstaande vak kun je de naam van een land invoeren maar dat is niet handig want dat beperkt de boel tot dat land. Beter is om naar een cel te verwijzen in dit geval F2. Telkens als je nu de waarde in F2 verandert, verandert ook de kleurmarkering al naar gelang het land dat je invoert.
Let op ! ! ! In het rechtervak kun je nog een mooie opmaak kiezen. Experimenteren maar.

Uiteindelijk kun je dit als resultaat krijgen

Oorspronkelijk geplaatst op: 4 mei 2014

Het probleem is dat je dubbele waarden in kolom A hebt. In dit voorbeeld zijn dat groente en fruit in het bereik A4:A20.

Met de functie VERT.ZOEKEN kun je daarom niet goed uit de voeten. Echter, je kunt kolom A en Kolom B samenvoegen in je formule d.m.v. het & teken. Met de functies INDEX en VERGELIJKEN kun je toch de juiste waarden opzoeken.

In cel C3 de formule:

=ALS.FOUT(INDEX($G$4:$G$20;VERGELIJKEN(A4&B4;$E$4:$E$20&$F$4:$F$20;0));””)

Let op ! ! ! Dit is een Matrixformule en MOET ingevoerd worden met Ctrl+Shift+Enter dus NIET met ENTER.

P.s. Je kunt de kolommen natuurlijk ook verwisselen. B wordt A en A wordt B maar daar gaat het hier niet om.

Oorspronkelijk geplaatst op: 4 mei 2014

Eenvoudig voorbeeld van de functie KIEZEN.

Vroeger kreeg je een rapport met daarop cijfers en een omschrijving die bij dat cijfer hoorde. Je weet wel:
“Zeer slecht”, “Slecht”, “Ruim onvoldoende” etc. Hoe weet je nu bij welk cijfer de juiste omschrijving hoort? Door gebruik te maken van de functie KIEZEN kun je dat achterhalen.

De formule die we in cel F11 invoeren is:

=KIEZEN(E11;”Zeer slecht”;”Slecht”; “Ruim onvoldoende”;”Onvoldoende”;
“Twijfelachtig”;”Voldoende”;”Ruim voldoende”;”Goed”;”Zeer goed”;”Uitstekend”)

Vervolgens doorvoeren tot en met cel F20. Je krijgt dan zoiets. Cijfers in E11:E20.

Maar de werkelijk kracht van de functie KIEZEN zie je hieronder in combinatie met de functie VERT.ZOEKEN. De opzet. Je hebt 3 tabellen genaamd tabel1, tabel2 en tabel3.

Formule in cel C11:

=VERT.ZOEKEN(B11;KIEZEN(A11;tabel1;tabel2;tabel3);2;ONWAAR)

KIEZEN(A11;tabel1;tabel2;tabel3) betekent dat KIEZEN in kolom A kijkt, of meer specifiek in cel A11. In die kolom staan de nummers 1, 2 en 3. De functie kiest dus een getal. Dit getal wordt gebruikt om de respectievelijke tabel te kiezen. Vervolgens neemt VERT.ZOEKEN de waarde in kolom B of meer specifiek cel B11 en zoekt dat op in de tabel die KIEZEN heeft geselecteerd. De formule kun je doorvoeren tot C20.

Oorspronkelijk geplaatst op: 12 mei 2014

Probleem:

Gegevens vanaf [A2] in het volgende formaat:
Achternaam Voornaam Nummer

Bijvoorbeeld:
Smith John 12345678

Eindresultaat moet zijn:
[B2] = Nummer
[C2] = Initialen van Voornamen en vervolgens Achternaam.

Het eerste woord in [A2] is altijd de Achternaam. Het laatste gegeven is altijd het Nummer. Alle woorden tussen Achternaam en Nummer zijn Voornamen en vormen de initialen in [C2].

Bijvoorbeeld:
[A2] = Smith John James 12346578

Eindresultaat:
[B2]: 12345678
[C2]: J J Smith

Formule [B2]:

=RIGHT(A2;LEN(A2)-FIND(“¶”;SUBSTITUTE(A2;” “;”¶”;LEN(A2)-LEN(SUBSTITUTE(A2;” “;””)))))

Formule [C2]:

=CONCATENATE(MID(A2;FIND(” “;A2)+1;1);” “;MID(A2;FIND(” “;A2;FIND(” “;A2)+1)+1;1);” “;LEFT(A2;FIND(” “;A2)-1))

Dit is de mooie en flexibele oplossing.

De volgende VBA‑functie (werkt voor onbeperkt aantal voornamen)

In Excel: ALT + F11 → Insert → Module → plak dit:

Function InitialsAndLastName(fullname As String) As String
    Dim parts() As String
    Dim i As Integer
    Dim result As String
    
    parts = Split(fullname, " ")
    
    ' Last name is first element
    Dim lastname As String
    lastname = parts(0)
    
    ' Build initials from all middle names
    For i = 1 To UBound(parts) - 1
        result = result & Left(parts(i), 1) & " "
    Next i
    
    InitialsAndLastName = Trim(result & lastname)
End Function

Function InitialsAndLastName(fullname As String) As String
    Dim parts() As String
    Dim i As Integer
    Dim result As String
    
    parts = Split(fullname, " ")
    
    ' Last name is first element
    Dim lastname As String
    lastname = parts(0)
    
    ' Build initials from all middle names
    For i = 1 To UBound(parts) - 1
        result = result & Left(parts(i), 1) & " "
    Next i
    
    InitialsAndLastName = Trim(result & lastname)
End Function

Gebruiken in bijvoorbeeld C2: =InitialsAndLastName(A2)

Voor het extraheren van het nummer in B2:
=RIGHT(A2;LEN(A2)-FIND(“¶”;SUBSTITUTE(A2;” “;”¶”;LEN(A2)-LEN(SUBSTITUTE(A2;” “;””)))))

Die VBA functie is veelzijdiger en robuuster en werkt als er meerdere voornamen zijn.

Oorspronkelijk geplaatst op: 12 mei 2014

In een rij staan in diverse cellen dubbele waarden. We willen echter alleen unieke waarden hebben. De functie zorgt er voor dat die dubbele waarden worden genegeerd en het resultaat in één cel wordt gezet waarbij de waarden door een komma worden gescheiden.

Function Dubbels(Target As Range, q As Boolean) As String
Dim rngCell As Range
Dim Resultaat As String

Resultaat = Empty

For Each rngCell In Target
If Not rngCell = Empty Then
    If q = False Then
        If Resultaat = Empty Then
            Resultaat = rngCell
        Else
            Resultaat = Resultaat & ", " & rngCell
        End If
    Else
        If InStr(Resultaat, rngCell) = 0 Then
            If Resultaat = Empty Then
                Resultaat = rngCell
            Else
                Resultaat = Resultaat & ", " & rngCell
            End If
        End If
    End If
End If
Next rngCell

Dubbels = Resultaat
End Function

Function Dubbels(Target As Range, q As Boolean) As String
Dim rngCell As Range
Dim Resultaat As String

Resultaat = Empty

For Each rngCell In Target
If Not rngCell = Empty Then
    If q = False Then
        If Resultaat = Empty Then
            Resultaat = rngCell
        Else
            Resultaat = Resultaat & ", " & rngCell
        End If
    Else
        If InStr(Resultaat, rngCell) = 0 Then
            If Resultaat = Empty Then
                Resultaat = rngCell
            Else
                Resultaat = Resultaat & ", " & rngCell
            End If
        End If
    End If
End If
Next rngCell

Dubbels = Resultaat
End Function