Question

我试图获取可变长度字符串集合中的术语频率。上下文是Access数据库中的描述。宁愿将解决方案保留在VBA中。分隔符是＆＃34; ＆＃34; （空格）角色

Dim db As DAO.Database
Set db = CurrentDb()

Call wordfreq

End Sub

Function wordfreq()

    Dim myCol As Collection
    Dim myArray() As String
    Dim strArray As Variant
    Dim strDescr, strTerm, strMsg As String
    Dim i, j As Integer

    Set myCol = New Collection

    strDescr = "here it should accept the table and display the result in seperate table"
'    db.Execute "select columns from table"

    myArray = Split(strDescr, " ")

    For Each strArray In myArray
        On Error Resume Next
        myCol.Add strArray, CStr(strArray)
    Next strArray

    For i = 1 To myCol.Count
        strTerm = myCol(i)
        j = 0
        For Each strArray In myArray
            If strArray = strTerm Then j = j + 1
        Next strArray
        'placeholder
        strMsg = strMsg & strTerm & " --->" & j & Chr(10) & Chr(13)
    Next i

    'placeholder
    'save results into a table
    MsgBox strMsg

End Function

Answer 1

使用Scripting.Dictionary对象查看下面的示例。

Function wordfreq()

    Dim objDict As Object
    Dim myArray() As String
    Dim strInput As String
    Dim idx As Long

    Set objDict = CreateObject("Scripting.Dictionary")
    strInput = "here it should accept the table and display the result in seperate table"
    myArray = Split(strInput, " ")

    For idx = LBound(myArray) To UBound(myArray)
        If Not objDict.Exists(myArray(idx)) Then
            'Add to dictionary with a count of 1
            objDict(myArray(idx)) = 1
        Else
            'Increment counter
            objDict(myArray(idx)) = objDict(myArray(idx)) + 1
        End If

    Next

    'Test it
    Dim n As Variant
    For Each n In objDict.Keys
        Debug.Print "Word: " & n, " Count: " & objDict(n)
    Next
End Function

输出：

'Word: here                  Count: 1
'Word: it                    Count: 1
'Word: should                Count: 1
'Word: accept                Count: 1
'Word: the                   Count: 2
'Word: table                 Count: 2
'Word: and                   Count: 1
'Word: display               Count: 1
'Word: result                Count: 1
'Word: in                    Count: 1
'Word: seperate              Count: 1

修改

过程：

循环输入 recordset。
将说明拆分为单词。
检查Dictionary和添加或中是否存在该字词的增量即可。
添加前述的Keys（字数）和Values（计数） Dictionary到输出表格。

为了实现这一目标，已经设置了两个辅助函数：

一个循环遍历描述recordset并返回一个 Dictionary对象填充了Keys及其唯一的单词算作Values。
另一个获取上述Dictionary对象并将其添加到Output表中。

您需要将[TABLE]更改为输入和输出表的名称。

Option Explicit

Sub WordsFrequency()
    On Error GoTo ErrTrap

    Dim rs As DAO.Recordset
    Set rs = CurrentDb().OpenRecordset("SELECT Description FROM [TABLE] WHERE Description Is Not Null;", dbOpenSnapshot)
    If rs.EOF Then GoTo Leave
    With rs
        .MoveLast
        .MoveFirst
    End With

    If AddDictionaryToTable(ToDictionary(rs)) Then
        MsgBox "Completed successfully.", vbInformation
    End If

Leave:
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing
    On Error GoTo 0
    Exit Sub

ErrTrap:
    MsgBox Err.Description, vbCritical
    Resume Leave
End Sub

' Returns Scripting.Dictionary object
Private Function ToDictionary(rs As DAO.Recordset) As Object

    Dim d As Object             'Dictionary
    Dim v As Variant            'Words
    Dim w As String             'Word
    Dim i As Long, ii As Long   'Loops

    Set d = CreateObject("Scripting.Dictionary")

    For i = 1 To rs.RecordCount
        v = Split(rs![Description], " ")

        For ii = LBound(v) To UBound(v)
            w = Trim(v(ii))
            If Not d.Exists(w) Then d(w) = 1 Else d(w) = d(w) + 1
        Next

        rs.MoveNext
    Next

    Set ToDictionary = d
End Function

' Adds Dictionary object to table
Private Function AddDictionaryToTable(objDict As Object) As Boolean
    On Error GoTo ErrTrap

    Dim rs As DAO.Recordset
    Dim n As Variant

    Set rs = CurrentDb().OpenRecordset("[TABLE]")
    With rs
        For Each n In objDict.Keys
            .AddNew
            .Fields("Words").Value = n
            .Fields("Counts").Value = objDict(n)
            .Update
        Next
    End With

    'all good
    AddDictionaryToTable = True

Leave:
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing
    On Error GoTo 0
    Exit Function

ErrTrap:
    MsgBox Err.Description, vbCritical
    Resume Leave
End Function

将解决方案保留在VBA中

1 个答案:

修改