Public Function basRndRecs(RecSet As String)
'Need to get a random number of RANDOM records from a recordset
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qdf As QueryDef
Dim RecCnt As Long 'HOW many are available
Dim NRecs As Long 'How many we Will Return
Dim Idx As Long 'Just another index
Dim Jdx As Long 'And One more (index) fior the road?
Dim tmpRecNum As Long 'Trial Record Number to Add to "List"
Dim RecNums() As Long 'Actual Records (Ordinal Position)
Dim strSql As String 'A mechanisim to create the "Random RecordSet"
On Error GoTo ErrExit
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(RecSet, dbOpenDynaset)
'First, Get the RecordCount
rst.MoveLast
rst.MoveFirst
RecCnt = rst.RecordCount
NRecs = CLng(Rnd() * RecCnt)
'This would be the place to LIMIT (both Hi and Lo!)
'the number or Percentage of Records to Return
'Here, I'll use 10% for the Low and 35% for the High.
'substitute your desired percentages or change to Absoloute Numbers
If (NRecs > 0.35 * RecCnt) Then
NRecs = CLng(0.35 * RecCnt)
End If
If (NRecs < 0.1 * RecCnt) Then
NRecs = CLng(0.1 * RecCnt)
End If
'Get the proposed records to Return
ReDim RecNums(NRecs) 'Make it the "correct size
For Idx = 1 To NRecs
RecNums(Idx) = CLng((Rnd() * RecCnt) + 1)
Next Idx
'Remove Duplicates from Proposed. In theory, this could 'upset' the
'number / percentage of records returned. Since we are supposed to
'return a RANDOM # of record, Who would know?
For Idx = 0 To UBound(RecNums) - 1
For Jdx = Idx + 1 To UBound(RecNums)
If (RecNums(Jdx) = RecNums(Idx)) Then
'Houston, we have a problem Here.
'Set the Record Number to "Invalid"
RecNums(Jdx) = -1
End If
Next Jdx
Next Idx
'Need to Delete the temp Table - If it Exists
DoCmd.DeleteObject acTable, RecSet & "Temp"
'Now, create a temp recordset with from the original recordset
'Here, I'll use a make table query, as it always create SOME recordset
strSql = "Select " & RecSet & ".*, 0 as RecSel Into " & RecSet & "Temp" & " "
strSql = strSql & "From " & RecSet & ";"
Set qdf = dbs.CreateQueryDef("", strSql)
qdf.Execute
'strSql.Execute 'strSql
Set rst = dbs.OpenRecordset(RecSet & "Temp", dbOpenDynaset)
With rst
.MoveLast
.MoveFirst
For Idx = 0 To UBound(RecNums)
If (RecNums(Idx) > 0) Then
.AbsolutePosition = RecNums(Idx)
.Edit
!RecSel = Idx
.Update
End If
Next Idx
End With
strSql = "Delete * From " & RecSet & "Temp Where RecSel = 0;"
Set qdf = dbs.CreateQueryDef("", strSql)
qdf.Execute
'Here. The 'original Record set has been "Cloned", and a random number
'of randomly selected records has been retained, with all others deleted.
ErrExit:
If (Err = 7874) Then 'Object Not found
Resume Next
End If
End Function
Will you be revisiting this thread with that aforementioned function, [COLOR=660000]MichaelRed[/color]? I'd sure appreciate the assistance.