Wrox Programmer Forums
Go Back   Wrox Programmer Forums > Microsoft Office > Access and Access VBA > Access VBA
|
Access VBA Discuss using VBA for Access programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Access VBA section of the Wrox Programmer to Programmer discussions. This is a community of software programmers and website developers including Wrox book authors and readers. New member registration was closed in 2019. New posts were shut off and the site was archived into this static format as of October 1, 2020. If you require technical support for a Wrox book please contact http://hub.wiley.com
 
Old March 16th, 2006, 06:16 PM
Authorized User
 
Join Date: Feb 2006
Posts: 33
Thanks: 0
Thanked 0 Times in 0 Posts
Default Finding Values and counting scattered through data

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
__________________
ScottP
 
Old March 17th, 2006, 01:00 AM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts
Default

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


 
Old March 17th, 2006, 01:32 PM
Authorized User
 
Join Date: Feb 2006
Posts: 33
Thanks: 0
Thanked 0 Times in 0 Posts
Default

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
 
Old March 17th, 2006, 03:37 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts
Default

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

 
Old March 17th, 2006, 04:19 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts
Default

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

 
Old March 17th, 2006, 04:24 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts
Default

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

in the code above should read

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

Bob

 
Old March 17th, 2006, 04:53 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts
Default

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

 
Old March 17th, 2006, 05:17 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts
Default

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

 
Old March 17th, 2006, 05:24 PM
Authorized User
 
Join Date: Feb 2006
Posts: 33
Thanks: 0
Thanked 0 Times in 0 Posts
Default

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
 
Old March 17th, 2006, 09:40 PM
Friend of Wrox
 
Join Date: Jun 2003
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts
Default

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






Similar Threads
Thread Thread Starter Forum Replies Last Post
Finding identical values voskoue Access VBA 7 January 30th, 2007 08:43 AM
Counting Number of Rows Between Data Range eusanpe Excel VBA 6 September 21st, 2006 07:17 AM
finding "c# data security handbook" code gzfarmer C# 2 April 26th, 2006 03:32 AM
Finding values from duplicated nodes swwallace XSLT 1 March 2nd, 2006 05:21 AM
Finding , Locatin and Receiving data with XML. betzy XML 2 May 25th, 2004 07:45 AM





Powered by vBulletin®
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright (c) 2020 John Wiley & Sons, Inc.