Hoe vaak komt dat woord voor?

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

Leave a Reply

Your email address will not be published. Required fields are marked *