Finding Values and counting scattered through data

Scootterp · March 16th, 2006, 06:16 PM

This is driving me crazy.

I have a table that has ten columns, CF1 to CF10. When entering info into these fields a combo box is used that has 60 options. You can only have one option in each record, but you can have "AR Code" in record 1 column CF2, and have "AR Code" in record 2, column CF9. I need to identify each Option in the table and then do a count of that option.

Is this possible?

It is getting close to St Patrick's Day, should I get out the big bottle of Irish Whiskey?

Scott

Bob Bedell · March 17th, 2006, 01:00 AM

Lets say you have a 6 column table that you've scattered option values throughout, and the available options are A, B, or C. It would look something like the following (though this probably won't format quite right).

Code:

"ID"    "Column1"    "Column2"    "Column3"    "Column4"    "Column5"    "Column6"
1    "A"        "A"        "A"        "A"        "A"        "B"
2    "C"        "B"        "A"        "B"        "C"        "C"
3    "A"        "B"        "A"        "A"        "B"        "A"

Then you want to count the number of times A, B, and C appear in the table. Thats my take on your problem. So you want output that would look like:

Code:

A =  10 
B =  5 
C =  3

The following procedure will get it for you:

Code:

Sub Test()

    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim fld As DAO.Field
    Dim strSQL As String, key As String
    Dim index As Long, total As Long
    Dim OptionCounts As Collection
    Dim OptionNames As Collection

    Set OptionCounts = New Collection
    Set OptionNames = New Collection

    Set db = CurrentDb()

    strSQL = "SELECT Column1, Column2, Column3, " & _
                    "Column4 , Column5, Column6 " & _
             "FROM tblData"

    Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)
    rst.MoveFirst
    Do Until rst.EOF
        For Each fld In rst.Fields
            On Error Resume Next
            total = 0
            key = fld.Value
            total = OptionCounts(key)
            OptionCounts.Remove key
            OptionCounts.Add total + 1, key
            OptionNames.Add key, key
        Next fld
        rst.MoveNext
    Loop
    On Error GoTo 0

    For index = 1 To OptionNames.Count
        Debug.Print OptionNames(index); " = "; OptionCounts(OptionNames(index))
    Next
End Sub

HTH,

Bob

Scootterp · March 17th, 2006, 01:32 PM

Bob, thanks, the code seems to be working, but is there a way to make it output the results to a form or to a table?

Thanks,
Scott

ScottP

Bob Bedell · March 17th, 2006, 03:37 PM

Hi Scott,

I revised the output portion of the code (and added a second recordset object) to create and write to an output table instead of the immediate window. Also added a function to check if the output table exists, and drop it if it does, so you can load the table with new values.

Code:

Sub Test()

    Dim db As DAO.Database
    Dim rstOriginalData As DAO.Recordset
    Dim rstOutputData As DAO.Recordset
    Dim fld As DAO.Field
    Dim strSQL As String, key As String
    Dim index As Long, total As Long
    Dim OptionCounts As Collection
    Dim OptionNames As Collection

    Set OptionCounts = New Collection
    Set OptionNames = New Collection

    Set db = CurrentDb()

    ' Open recordset of Original Data.
    strSQL = "SELECT Column1, Column2, Column3, " & _
                    "Column4 , Column5, Column6 " & _
             "FROM tblData"
    Set rstOriginalData = db.OpenRecordset(strSQL, dbOpenSnapshot)
    rstOriginalData.MoveFirst

    ' Loop through original data, performing option count, and
    ' populating collection objects.
    Do Until rstOriginalData.EOF
        For Each fld In rstOriginalData.Fields
            On Error Resume Next
            total = 0
            key = fld.Value
            total = OptionCounts(key)
            OptionCounts.Remove key
            OptionCounts.Add total + 1, key
            OptionNames.Add key, key
        Next fld
        rstOriginalData.MoveNext
    Loop
    On Error GoTo 0

    ' =======================================
    ' Output option counts to tblOptionCounts
    ' =======================================

    ' If output table already exists, drop it.
    If TableExists("tblOptionCounts") Then
        db.Execute "DROP TABLE tblOptionCounts"
    End If

    ' Create output table with two fields.
    db.Execute _
        "CREATE TABLE tblOptionCounts (OptionName String, OptionCount Long)"

    ' Open recordset for option count output.
    Set rstOutputData = db.OpenRecordset("tblOptionCounts", dbOpenTable)

    ' Write option counts to table.
    With rstOutputData
        For index = 1 To OptionNames.Count
            .AddNew
            !OptionName = OptionNames(index)
            !OptionCount = OptionCounts(OptionNames(index))
            .Update
        Next index
    End With

End Sub

Public Function TableExists(strTableName As String) As Boolean

    Dim tdf As DAO.TableDef

    TableExists = False

    For Each tdf In CurrentDb.TableDefs
        If tdf.Name = strTableName Then
            TableExists = True
            Exit For
        End If
    Next

End Function

HTH,

Bob

Bob Bedell · March 17th, 2006, 04:19 PM

Hi Scott,

If you want to display the values in a form control, like a listbox, set the listbox's Row Source Type property to 'Value List', and its Column Width property to '2'. Name the control 'lstOptionCounts'. Then place the following in the click event of a command button named 'cmdPopulateListbox' (I moved the db object variable to module level):

Code:

Dim m_db As DAO.database

Private Sub cmdPopulateListbox_Click()
    Dim rstOriginalData As DAO.Recordset
    Dim rstOutputData As DAO.Recordset
    Dim fld As DAO.Field
    Dim strSQL As String, key As String
    Dim index As Long, total As Long
    Dim OptionCounts As Collection
    Dim OptionNames As Collection

    Set OptionCounts = New Collection
    Set OptionNames = New Collection

    Set m_db = CurrentDb()

    ' Open recordset of Original Data.
    strSQL = "SELECT Column1, Column2, Column3, " & _
                    "Column4 , Column5, Column6 " & _
             "FROM tblData"
    Set rstOriginalData = m_db.OpenRecordset(strSQL, dbOpenSnapshot)
    rstOriginalData.MoveFirst

    ' Loop through original data, performing option count, and
    ' populating collection objects.
    Do Until rstOriginalData.EOF
        For Each fld In rstOriginalData.Fields
            On Error Resume Next
            total = 0
            key = fld.Value
            total = OptionCounts(key)
            OptionCounts.Remove key
            OptionCounts.Add total + 1, key
            OptionNames.Add key, key
        Next fld
        rstOriginalData.MoveNext
    Loop
    rstOriginalData.Close
    On Error GoTo 0

    ' ====================================
    ' Output options count listbox control
    ' ====================================

    ' If output table already exists, drop it.
    If TableExists("tblOptionCounts") Then
        m_db.Execute "DROP TABLE tblOptionCounts"
    End If

    ' Create output table with two fields.
    m_db.Execute _
        "CREATE TABLE tblOptionCounts (OptionName String, OptionCount Long)"

    ' Open recordset for option count output.
    Set rstOutputData = m_db.OpenRecordset("tblOptionCounts", dbOpenTable)

    ' Write option counts to table.
    With rstOutputData
        For index = 1 To OptionNames.Count
            .AddNew
            !OptionName = OptionNames(index)
            !OptionCount = OptionCounts(OptionNames(index))
            .Update
        Next index
    End With
    rstOutputData.Close

    ' =========================================
    ' Populate listbox control with output data
    ' =========================================
    Call FillListBox

End Sub

Public Function TableExists(strTableName As String) As Boolean

    Dim tdf As DAO.TableDef

    TableExists = False

    For Each tdf In CurrentDb.TableDefs
        If tdf.Name = strTableName Then
            TableExists = True
            Exit For
        End If
    Next

End Function

Private Sub FillListBox()
    Dim rstListBoxOutput As DAO.Recordset
    Dim strList As String
    Dim strSQL As String

    strSQL = "SELECT * FROM tblOptionCounts " _
        & "ORDER BY OptionName"

    Set rstListBoxOutput = m_db.OpenRecordset(strSQL, dbOpenDynaset)

    strList = BuildString(rstListBoxOutput)
    Me.lstOptionCounts.RowSource = strList
    rstListBoxOutput.Close
End Sub

Private Function BuildString(rst As DAO.Recordset) As String
    Dim strReturn As String
    Dim varItems As Variant
    Dim x As Integer
    Dim y As Integer

    rst.MoveFirst

    varItems = rst.GetRows(10)
    For x = LBound(varItems, 2) To UBound(varItems, 2)
        For y = LBound(varItems, 1) To UBound(varItems, 1)
            strReturn = strReturn & varItems(y, x) & ";"
        Next y
    Next x
    BuildString = strReturn
End Function

HTH,

Bob

Bob Bedell · March 17th, 2006, 04:24 PM

' ====================================
' Output options count listbox control
' ====================================

in the code above should read

' ================================
' Output options count to table
' ================================

Bob

Bob Bedell · March 17th, 2006, 04:53 PM

Here's the ADO version just 'cause I got way to much time on my hands:

Code:

Dim m_cnn As ADODB.Connection

Private Sub cmdPopulateListbox_Click()
    Dim rstOriginalData As ADODB.Recordset
    Dim rstOutputData As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim strSQL As String, key As String
    Dim index As Long, total As Long
    Dim varFields As Variant
    Dim varValues As Variant
    Dim OptionCounts As Collection
    Dim OptionNames As Collection

    Set OptionCounts = New Collection
    Set OptionNames = New Collection

    Set m_cnn = CurrentProject.Connection

    ' Open recordset of Original Data.
    strSQL = "SELECT Column1, Column2, Column3, " & _
                    "Column4 , Column5, Column6 " & _
             "FROM tblData"
    Set rstOriginalData = New ADODB.Recordset
    rstOriginalData.Open strSQL, m_cnn, adOpenForwardOnly, adLockReadOnly, adCmdText

    ' Loop through original data, performing option count, and
    ' populating collection objects.
    Do Until rstOriginalData.EOF
        For Each fld In rstOriginalData.Fields
            On Error Resume Next
            total = 0
            key = fld.Value
            total = OptionCounts(key)
            OptionCounts.Remove key
            OptionCounts.Add total + 1, key
            OptionNames.Add key, key
        Next fld
        rstOriginalData.MoveNext
    Loop
    rstOriginalData.Close
    On Error GoTo 0

    ' ================================
    ' Output options count to table
    ' ================================

    ' If output table already exists, drop it.
    If TableExists("tblOptionCounts") Then
        m_cnn.Execute "DROP TABLE tblOptionCounts"
    End If

    ' Create output table with two fields.
    m_cnn.Execute _
        "CREATE TABLE tblOptionCounts (OptionName String, OptionCount Long)"

    ' Open recordset for option count output.
    Set rstOutputData = New ADODB.Recordset
    rstOutputData.Open "tblOptionCounts", m_cnn, adOpenKeyset, adLockOptimistic, adCmdTable

    ' Write option counts to table.
    With rstOutputData
        For index = 1 To OptionNames.Count
            varFields = Array("OptionName", "OptionCount")
            varValues = Array(OptionNames(index), OptionCounts(OptionNames(index)))
            rstOutputData.AddNew varFields, varValues
        Next index
    End With
    rstOutputData.Close

    ' =========================================
    ' Populate listbox control with output data
    ' =========================================
    Call FillListBox

End Sub

Public Function TableExists(strTableName As String) As Boolean

    Dim tdf As DAO.TableDef

    TableExists = False

    For Each tdf In CurrentDb.TableDefs
        If tdf.Name = strTableName Then
            TableExists = True
            Exit For
        End If
    Next

End Function

Private Sub FillListBox()
    Dim rstListBoxOutput As ADODB.Recordset
    Dim strList As String
    Dim strSQL As String

    strSQL = "SELECT * FROM tblOptionCounts " _
        & "ORDER BY OptionName"

    Set rstListBoxOutput = New ADODB.Recordset
    rstListBoxOutput.Open strSQL, m_cnn, adOpenForwardOnly, adLockReadOnly, adCmdText

    strList = BuildString(rstListBoxOutput)
    Me.lstOptionCounts.RowSource = strList
    rstListBoxOutput.Close
End Sub

Private Function BuildString(rst As ADODB.Recordset) As String
    Dim strReturn As String
    Dim varItems As Variant
    Dim x As Integer
    Dim y As Integer

    rst.MoveFirst

    varItems = rst.GetRows(10)
    For x = LBound(varItems, 2) To UBound(varItems, 2)
        For y = LBound(varItems, 1) To UBound(varItems, 1)
            strReturn = strReturn & varItems(y, x) & ";"
        Next y
    Next x
    BuildString = strReturn
End Function

HTH,

Bob

Bob Bedell · March 17th, 2006, 05:17 PM

Oop..didn't rewrite the 'TableExists' function. Here's an ADO version:

Code:

Private Function TableExists(strTableName As String) As Boolean

    On Error GoTo Err_Handler

    Dim rst As ADODB.Recordset
    Set rst = New ADODB.Recordset
    rst.Open "SELECT * FROM " & strTableName & " WHERE 1=0", m_cnn

    TableExists = True

Exit_Here:
    If rst.State = adStateOpen Then rst.Close
    Set rst = Nothing
    Exit Function

Err_Handler:
    GoTo Exit_Here

End Function

Bob

Scootterp · March 17th, 2006, 05:24 PM

Thanks Bob....for having too much time on your hands. This will take me awhile to go through, thanks and have a great weekend.

Scott

Bob Bedell · March 17th, 2006, 09:40 PM

Hi Scott,

Just gotta' mention one important correction. In the BuildString routine that builds the listbox's value list string I used:

varItems = rst.GetRows(10)

which 'll only list the first 10 records in the recordset. Just use the recordset's RecordCount value with GetRows():

DAO Version

Code:

Private Function BuildString(rst As DAO.Recordset) As String
    Dim strReturn As String
    Dim varItems As Variant
    Dim x As Integer
    Dim y As Integer
    Dim intRecordCount As Integer

    ' Get record count
    rst.MoveLast
    intRecordCount = rst.RecordCount
    rst.MoveFirst

    varItems = rst.GetRows(intRecordCount)
    For x = LBound(varItems, 2) To UBound(varItems, 2)
        For y = LBound(varItems, 1) To UBound(varItems, 1)
            strReturn = strReturn & varItems(y, x) & ";"
        Next y
    Next x
    BuildString = strReturn
End Function

ADO Version

Code:

Private Function BuildString(rst As ADODB.Recordset) As String
    Dim strReturn As String
    Dim varItems As Variant
    Dim x As Integer
    Dim y As Integer
    Dim intRecordCount As Integer

    intRecordCount = rst.RecordCount

    varItems = rst.GetRows(intRecordCount)
    For x = LBound(varItems, 2) To UBound(varItems, 2)
        For y = LBound(varItems, 1) To UBound(varItems, 1)
            strReturn = strReturn & varItems(y, x) & ";"
        Next y
    Next x
    BuildString = strReturn
End Function

Bob