Ms access 将解决方案保存在VBA中

我试图获取可变长度字符串集合中术语的频率。上下文是Access数据库中的描述。希望将解决方案保存在VBA中。分隔符是“”（空格）字符

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

---

请参见下面使用

脚本.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

编辑 过程：

循环通过输入

记录集

将描述拆分为单词

检查单词是否存在于

词典中

和添加中或 增量

添加前面提到的

键

（单词）和

值

（计数）

字典

到输出表

为了实现这一点，设置了两个辅助功能：

其中一个循环遍历描述

记录集

，并返回一个

Dictionary

对象中填充了唯一的单词，如

键

及其 计数为

值

另一个获取上面的

Dictionary

对象并将其添加到输出表中

您需要将

[TABLE]

更改为输入和输出表的名称

---

---

---

---

使用dictionary对象进行频率计数比使用集合自然得多。看这个：你能帮我写代码吗，伙计，你真的希望我为你写整个程序吗？表现出一些努力，并尝试将上述示例应用到您的程序中。如果你被卡住了，那就去问。我在vbai方面很弱。我已经在上面的问题中添加了截图，它有表名字段和列。请查收并告知

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