Identify Common Words/Combination of Words

[ItsMeH]

Hi,

Hi,

I've found this piece of VBA code on another forum which lists the the number of times a word and/or combination of words is used from a column in Excel. I'd like to replicate it using a table in access containing 'free text' and by creating a table for the output with a singlular list of words/combination of words.
e.g. tbl_FrequencyOutput
Col1= No of Words
Col 2= Word/Combination
Col 3= Count of combination in list.

Sub Test()
    PhraseDensity 1, "B"
    PhraseDensity 2, "D"
    PhraseDensity 3, "F"
End Sub

Sub PhraseDensity(nWds As Long, Col As Variant)
    Dim astr()      As String
    Dim i           As Long
    Dim j           As Long
    Dim cell        As Range
    Dim sPair       As String
    Dim rOut        As Range

    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For Each cell In Range("A1", Cells(Rows.Count, "A").End(xlUp))
            astr = Split(Letters(cell.Value), " ")

            For i = 0 To UBound(astr) - nWds + 1
                sPair = vbNullString
                For j = i To i + nWds - 1
                    sPair = sPair & astr(j) & " "
                Next j
                sPair = Left(sPair, Len(sPair) - 1)

                If Not .exists(sPair) Then
                    .Add sPair, 1
                Else
                    .Item(sPair) = .Item(sPair) + 1
                End If
            Next i
        Next cell

        Set rOut = Columns(Col).Resize(.Count, 2).Cells
        rOut.EntireColumn.ClearContents

        rOut.Columns(1).Value = Application.Transpose(.Keys)
        rOut.Columns(2).Value = Application.Transpose(.Items)

        rOut.Sort Key1:=rOut(1, 2), Order1:=xlDescending, _
                  Key2:=rOut(1, 1), Order1:=xlAscending, _
                  MatchCase:=False, Orientation:=xlTopToBottom, Header:=xlNo
        rOut.EntireColumn.AutoFit
    End With
End Sub

Function Letters(s As String) As String
    Dim i           As Long

    For i = 1 To Len(s)
        Select Case Mid(s, i, 1)
            Case "A" To "Z", "a" To "z", "'"
                Letters = Letters & Mid(s, i, 1)
            Case Else
                Letters = Letters & " "
        End Select
    Next i
    Letters = WorksheetFunction.Trim(Letters)
End Function

I appreciate any assistance and hope you're up for a challenge!

Regards,

H

 

[hvaznxl103]

Hi,

Hi,

I've found this piece of VBA code on another forum which lists the the number of times a word and/or combination of words is used from a column in Excel. I'd like to replicate it using a table in access containing 'free text' and by creating a table for the output with a singlular list of words/combination of words.
e.g. tbl_FrequencyOutput
Col1= No of Words
Col 2= Word/Combination
Col 3= Count of combination in list.

Sub Test()
    PhraseDensity 1, "B"
    PhraseDensity 2, "D"
    PhraseDensity 3, "F"
End Sub

Sub PhraseDensity(nWds As Long, Col As Variant)
    Dim astr()      As String
    Dim i           As Long
    Dim j           As Long
    Dim cell        As Range
    Dim sPair       As String
    Dim rOut        As Range

    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For Each cell In Range("A1", Cells(Rows.Count, "A").End(xlUp))
            astr = Split(Letters(cell.Value), " ")

            For i = 0 To UBound(astr) - nWds + 1
                sPair = vbNullString
                For j = i To i + nWds - 1
                    sPair = sPair & astr(j) & " "
                Next j
                sPair = Left(sPair, Len(sPair) - 1)

                If Not .exists(sPair) Then
                    .Add sPair, 1
                Else
                    .Item(sPair) = .Item(sPair) + 1
                End If
            Next i
        Next cell

        Set rOut = Columns(Col).Resize(.Count, 2).Cells
        rOut.EntireColumn.ClearContents

        rOut.Columns(1).Value = Application.Transpose(.Keys)
        rOut.Columns(2).Value = Application.Transpose(.Items)

        rOut.Sort Key1:=rOut(1, 2), Order1:=xlDescending, _
                  Key2:=rOut(1, 1), Order1:=xlAscending, _
                  MatchCase:=False, Orientation:=xlTopToBottom, Header:=xlNo
        rOut.EntireColumn.AutoFit
    End With
End Sub

Function Letters(s As String) As String
    Dim i           As Long

    For i = 1 To Len(s)
        Select Case Mid(s, i, 1)
            Case "A" To "Z", "a" To "z", "'"
                Letters = Letters & Mid(s, i, 1)
            Case Else
                Letters = Letters & " "
        End Select
    Next i
    Letters = WorksheetFunction.Trim(Letters)
End Function

I appreciate any assistance and hope you're up for a challenge!

Regards,

H

These words don’t combine well In English. What are you trying to describe that would need these words to describe it? The best I can think of is a Competitive Multimedia Innovation.

 

[plog]

That's too much code for me to get an idea of what you want--can you draw me a picture? A picture composed of data. Give us what your starting table will look like, show us what you want the output to look like and make sure the 2 sets of data jive--make sure the output is based on the input so we can determine the logic..

 

[Galaxiom]

Don't bother with clunky VBA code.
Put the table into SQL Server Express, install Advanced Services and set up Full Text Indexing.

You will then be able to do context search queries that find occurrences of words, words close to each other by a defined gap. It even finds other tenses and cases of the words such as plurals and past tense.

How to add full-text search to SQL Server Express 2019 installation

I have a local installation of Microsoft SQL Server Express 2019 and just hit the following error: Full-Text Search is not installed, or a full-text component cannot be loaded. So, my understandi...

stackoverflow.com

 

[arnelgp]

that was 12 years ago?

 

[MajP]

See implementation of Rake algorithm
Post in thread 'word index creator code would be good: possible?' https://www.access-programmers.co.u...de-would-be-good-possible.321240/post-1805764