none
Access VBA Random Sample Question RRS feed

  • Question

  • Hello,

    I have a form (frmRandomSampling) where the user selects how many Sample (txtSample) they would like to run. Then they select "Run Report". 

    Table below (tblEmployeeProduction) indicates "Employee ID” and “Item Number”

    This is the coding that I am using, it will pull proper sample for the department but not for each employee for that department. Let say the user select 2 sample it will pull 2 samples for the department instead of 2 samples for each employee with in that department.

    I am not a programmer, can you help with the coding?

    Thank you and have a good day!

    

    Private Sub BuildRandomTable()
    Dim dbsRandom       As Database
    Dim rstRequest      As Recordset
    Dim rstRandom       As Recordset
    Dim UpperLimit      As Long
    Dim LowerLimit      As Long
    Dim lngCounter      As Long
    Dim lngGuess        As Long
    Dim lngRequest      As Long
    Dim lngRecordCount  As Long

    ' This module is in the Current database.
    Set dbsRandom = CurrentDb

    ' Open table recordset.
    Set rstRequest = dbsRandom.OpenRecordset("tblEmployeeProduction")
    rstRequest.MoveFirst
    LowerLimit = rstRequest!ID
    rstRequest.MoveLast
    UpperLimit = rstRequest!ID
    lngRecordCount = rstRequest.RecordCount

    ' Build Random table

    Set rstRandom = dbsRandom.OpenRecordset("tblRandom", dbOpenDynaset)
    lngCounter = 1

    ' Check to make sure the number of
    ' records requested is reasonable.
    If lngRequest > lngRecordCount Then
        MsgBox "Request is greater than the total number of records."
    Exit Sub
    Else
        'lngRequest = lngRequest + 1
        lngRequest = Form_frmRandomSampling.txtSample + 1
    End If

    Randomize

        Do Until lngCounter = lngRequest
            ' Generate a random number
            lngGuess = Int((UpperLimit - LowerLimit + 1) * Rnd + LowerLimit)
            ' Ensure that it exists in the Orders table.
            rstRequest.Index = "PrimaryKey"
            rstRequest.Seek "=", lngGuess
                If rstRequest.NoMatch Then
                ' Drop through and generate a new number.
                Else
                ' Check to see if it's already been used in the new table.
                rstRandom.FindFirst "lngOrderNumber =" & lngGuess
                    ' If not, add it to the new table.
                    If rstRandom.NoMatch Then
                    With rstRandom
                    .AddNew
                    !lngGuessNumber = lngCounter
                    !lngOrderNumber = lngGuess
                    .Update
                    End With
                lngCounter = lngCounter + 1
                End If
            End If
        Loop
        ' Clean up.
        dbsRandom.Close

    End Sub


    Jay






    • Edited by Radio Fixer Tuesday, August 18, 2015 7:29 PM
    Thursday, August 6, 2015 7:08 PM

Answers

  • Hello Radio,

    I believe the following procedure will get you to where you want to be:

    Function CreateRandomProduction(StartDate As Date, EndDate As Date) As Boolean
    
        On Error GoTo Err_Process
        
        Dim strSQL As String
        Dim dbs1 As Database
        Dim rst1 As Recordset
        Dim rst2 As Recordset
        Dim varArr As Variant
        Dim lngRecs1 As Long
        Dim lngRecs2 As Long
        Dim lngRow1 As Long
        Dim lngRow2 As Long
        Dim lngItem1 As Long
        Dim lngItem2 As Long
        Dim lngProcessed As Long
        Dim blnReturn As Boolean
        Dim strMsg As String
        Dim intMsgType As Integer
        
        blnReturn = False
        lngProcessed = 0
        
        strSQL = "SELECT DISTINCT tblEmployeeProduction.EmployeeID " & _
        "FROM tblEmployeeProduction " & _
        "WHERE (((tblEmployeeProduction.DateOf) Between #" & StartDate & "# And #" & EndDate & "#))"
    
        Set dbs1 = CurrentDb
        Set rst1 = dbs1.OpenRecordset(strSQL, dbOpenSnapshot)
        
        With rst1
            If (Not .EOF) Then
                .MoveLast
                .MoveFirst
                lngRecs1 = .RecordCount
            End If
            
            Do While Not .EOF
                strSQL = "SELECT tblEmployeeProduction.ItemNumber " & _
                "FROM tblEmployeeProduction " & _
                "WHERE tblEmployeeProduction.DateOf Between #" & StartDate & "# And #" & EndDate & "# AND EmployeeID = '" & .Fields!EmployeeID & "'"
                
                Set rst2 = dbs1.OpenRecordset(strSQL, dbOpenSnapshot)
                
                With rst2
                    If (Not .EOF) Then
                        .MoveLast
                        .MoveFirst
                        lngRecs2 = .RecordCount
                        
                        lngRow1 = Int((lngRecs2 - 1 + 1) * Rnd + 1) - 1
                        Do
                            lngRow2 = Int((lngRecs2 - 1 + 1) * Rnd + 1) - 1
                        Loop While lngRow2 = lngRow1
                        
                        .AbsolutePosition = lngRow1
                        lngItem1 = .Fields(0)
                        
                        .AbsolutePosition = lngRow2
                        lngItem2 = .Fields(0)
                        
                        .Close
                        
                        strSQL = "INSERT INTO tblEmployeeProductionRnd ( EmployeeID, ItemNumber ) " & _
                        "Values ('" & rst1.Fields!EmployeeID & "', " & lngItem1 & ")"
                        dbs1.Execute strSQL, dbFailOnError
                        
                        strSQL = "INSERT INTO tblEmployeeProductionRnd ( EmployeeID, ItemNumber ) " & _
                        "Values ('" & rst1.Fields!EmployeeID & "', " & lngItem2 & ")"
                        dbs1.Execute strSQL, dbFailOnError
                        lngProcessed = lngProcessed + 1
                    End If
                End With
                .MoveNext
            Loop
            .Close
        End With
        
        blnReturn = (lngProcessed = lngRecs1)
        
        intMsgType = vbInformation
        If (Not blnReturn) Then
            intMsgType = vbExclamation
        End If
        
        MsgBox "Processed " & lngProcessed & " of " & lngRecs1 & ".", intMsgType, "Process Complete"
        
    Exit_Process:
        Set rst1 = Nothing
        Set rst2 = Nothing
        Set dbs1 = Nothing
        CreateRandomProduction = blnReturn
        Exit Function
        
    Err_Process:
        strMsg = "An unexpected error occurred in process: CreateRandomProduction()" & _
        vbCrLf & vbCrLf & _
        Err.Number & " " & Err.Description
        MsgBox strMsg, vbExclamation, "Error"
        Resume Exit_Process
    
    End Function
    

    It will expect the following two tables:

    Following a test of the procedure, your data and results appear as follows:

    Wednesday, August 26, 2015 1:11 AM
  • You did not supply the two required arguments for the function which are StartDate and EndDate.
    • Marked as answer by Radio Fixer Wednesday, September 9, 2015 8:23 PM
    Tuesday, September 8, 2015 10:51 PM

All replies

  • It is not clear to me what you are asking for. You should show us the structure of the table tblRandomFilter (the field names and types), together with some sample data and the desired result.

    Matthias Kläy, Kläy Computing AG

    Saturday, August 8, 2015 12:46 PM
  • Why do you need to loop thru it?

    Saturday, August 8, 2015 1:22 PM
  • Hi Antique,

    >>  I need to loop through each employee according to the sample size that was selected by user and pull random sample for each employee in that department.

    Based on your description and your title, you do not have issues about looping through each employee and have issues about pulling random sample. If you want to pull random values from a query or table, I think you could use Rad function to get index from department list, get the random department, then get the record or specific value according the department value with where statement in a query.

    # Rnd Function

    https://support.office.com/en-nz/article/Rnd-Function-503cd2e4-3949-413f-980a-ed8fb35c1d80

    # Introduction to queries

    https://support.office.com/en-us/article/Introduction-to-queries-a9739a09-d3ff-4f36-8ac3-5760249fb65c

    If I misunderstood you, please feel free to let me know.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Monday, August 10, 2015 3:23 AM
  • I have modify my original request, please see above

    Unfortunately I am not a programmer. This is the coding that I am using, it will pull proper sample for the department but not for each employee for that department. Let say the user select 2 sample it will pull 2 samples for the department instead of 2 samples for each employee with in that department.

    Thank you and have a good day!


    JayZ

    Tuesday, August 18, 2015 7:36 PM
  • Hi JayZ,

    Based on your new request, it seems that you want to query data with Selected date and txtSample, if so, I suggest you use query to achieve your requirement. For information about queries, you could refer my first reply. If you have issues about this, I think you could share us your query, your table design, the data you have and the result which you want.

    In addition, please do not modify your original post, it will misleading other community members. If your original post is not clearly, you could reply in your post instead of modifying it. If your new issue is not related with original post, please post a new thread for new issue instead of modifying it.

    Thanks for your understanding.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Wednesday, August 19, 2015 2:41 AM
  • Hi JayZ,

    Have your issue been resolved?

    >>Let say the user select 2 sample it will pull 2 samples for the department instead of 2 samples for each employee with in that department.

    I am not sure what you mean by this? It would be better if you could share us your table design and table data, and the result you want. In my option, you could use a query to achieve your requirement.

    If you have any issues about this, please feel free to let me know.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Friday, August 21, 2015 7:30 AM
  • Thank you for getting back with me.

    I have created a query that generates two columns “EmployeeID” and “ItemNumber”. What I am trying to do is loop through this query/table for each EmployeeID and then loop again to the same query/table pull some “ItemNnumber” for that employee. Something like this:

    Dim db          As Database
    Dim sql         As String
    Dim data1       As String
    Dim data2       As String
    Dim rstUser     As Recordset
    Dim rstItem     As Recordset
        
    'Current Database.
    Set db = CurrentDb

    sql = "Select * from tblEmployeeProduction;"
        
        Set rstUser = db.OpenRecordset(sql)
        
            Do Until rstUser.EOF

              'select each employee
      data1 = rstUser("EmployeeID")
                

                'based on selected employee pull item number
                Do Until rstItem.EOF

    'do Randomize


                Loop 'rstItem

        rstItem.MoveNext


    Loop 'rstUser

    rstUser.MoveNext

    CleanUp:

    Set data1 = Nothing
    Set data2 = Nothing
    Set tbl = Nothing
    Set db = Nothing


    JayZ

    Monday, August 24, 2015 4:47 PM
  • Hi JayZ,

    >>This is the coding that I am using, it will pull proper sample for the department but not for each employee for that department. Let say the user select 2 sample it will pull 2 samples for the department instead of 2 samples for each employee with in that department.

    What do you mean by this? I am not sure what is the relationship between your requirement and your code.

    Best Regards,

    Edward


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Tuesday, August 25, 2015 7:26 AM
  • Hello Radio,

    I believe the following procedure will get you to where you want to be:

    Function CreateRandomProduction(StartDate As Date, EndDate As Date) As Boolean
    
        On Error GoTo Err_Process
        
        Dim strSQL As String
        Dim dbs1 As Database
        Dim rst1 As Recordset
        Dim rst2 As Recordset
        Dim varArr As Variant
        Dim lngRecs1 As Long
        Dim lngRecs2 As Long
        Dim lngRow1 As Long
        Dim lngRow2 As Long
        Dim lngItem1 As Long
        Dim lngItem2 As Long
        Dim lngProcessed As Long
        Dim blnReturn As Boolean
        Dim strMsg As String
        Dim intMsgType As Integer
        
        blnReturn = False
        lngProcessed = 0
        
        strSQL = "SELECT DISTINCT tblEmployeeProduction.EmployeeID " & _
        "FROM tblEmployeeProduction " & _
        "WHERE (((tblEmployeeProduction.DateOf) Between #" & StartDate & "# And #" & EndDate & "#))"
    
        Set dbs1 = CurrentDb
        Set rst1 = dbs1.OpenRecordset(strSQL, dbOpenSnapshot)
        
        With rst1
            If (Not .EOF) Then
                .MoveLast
                .MoveFirst
                lngRecs1 = .RecordCount
            End If
            
            Do While Not .EOF
                strSQL = "SELECT tblEmployeeProduction.ItemNumber " & _
                "FROM tblEmployeeProduction " & _
                "WHERE tblEmployeeProduction.DateOf Between #" & StartDate & "# And #" & EndDate & "# AND EmployeeID = '" & .Fields!EmployeeID & "'"
                
                Set rst2 = dbs1.OpenRecordset(strSQL, dbOpenSnapshot)
                
                With rst2
                    If (Not .EOF) Then
                        .MoveLast
                        .MoveFirst
                        lngRecs2 = .RecordCount
                        
                        lngRow1 = Int((lngRecs2 - 1 + 1) * Rnd + 1) - 1
                        Do
                            lngRow2 = Int((lngRecs2 - 1 + 1) * Rnd + 1) - 1
                        Loop While lngRow2 = lngRow1
                        
                        .AbsolutePosition = lngRow1
                        lngItem1 = .Fields(0)
                        
                        .AbsolutePosition = lngRow2
                        lngItem2 = .Fields(0)
                        
                        .Close
                        
                        strSQL = "INSERT INTO tblEmployeeProductionRnd ( EmployeeID, ItemNumber ) " & _
                        "Values ('" & rst1.Fields!EmployeeID & "', " & lngItem1 & ")"
                        dbs1.Execute strSQL, dbFailOnError
                        
                        strSQL = "INSERT INTO tblEmployeeProductionRnd ( EmployeeID, ItemNumber ) " & _
                        "Values ('" & rst1.Fields!EmployeeID & "', " & lngItem2 & ")"
                        dbs1.Execute strSQL, dbFailOnError
                        lngProcessed = lngProcessed + 1
                    End If
                End With
                .MoveNext
            Loop
            .Close
        End With
        
        blnReturn = (lngProcessed = lngRecs1)
        
        intMsgType = vbInformation
        If (Not blnReturn) Then
            intMsgType = vbExclamation
        End If
        
        MsgBox "Processed " & lngProcessed & " of " & lngRecs1 & ".", intMsgType, "Process Complete"
        
    Exit_Process:
        Set rst1 = Nothing
        Set rst2 = Nothing
        Set dbs1 = Nothing
        CreateRandomProduction = blnReturn
        Exit Function
        
    Err_Process:
        strMsg = "An unexpected error occurred in process: CreateRandomProduction()" & _
        vbCrLf & vbCrLf & _
        Err.Number & " " & Err.Description
        MsgBox strMsg, vbExclamation, "Error"
        Resume Exit_Process
    
    End Function
    

    It will expect the following two tables:

    Following a test of the procedure, your data and results appear as follows:

    Wednesday, August 26, 2015 1:11 AM
  • Sorry for delay, I was on vacation. Thank you so much for taking your valuable time to help me with this.

    I am trying to call the Function which is located on the same form by using a below code and is giving me Compile Error message (Argument not optional). What I am missing?

    Private Sub cmdRunReport_Click()

           Call CreateRandomProduction

     End Sub

    Thank you so much!!!

    Jay


    JayZ

    Tuesday, September 8, 2015 5:19 PM
  • You did not supply the two required arguments for the function which are StartDate and EndDate.
    • Marked as answer by Radio Fixer Wednesday, September 9, 2015 8:23 PM
    Tuesday, September 8, 2015 10:51 PM
  • RunningManHD

    Your coding is working great, thank you so much!

    Below form give the user the ability to select dates and key the sample size (txtSample) so they can pull as many samples as they need. How can I add sample size (txtSample)  to your coding above so the user can have that ability?

    I truly appreciate your time!!! 


    JayZ



    • Edited by Radio Fixer Wednesday, September 9, 2015 8:22 PM
    Wednesday, September 9, 2015 8:15 PM