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

Afbeelding 2 (een gedeelte van het resultaat)

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.
Eerste code:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
Option Explicit Sub Hoe_Vaak_Komt_Dat_Woord_Voor() 'Zet Data in meerdere cellen van Kolom A. 'Data alleen in A1 geeft foutmelding 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 |
Tweede code:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
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 |