Selecting samples based on Criteria (1 Viewer)

[aryanaveen]

Hi All,

Please help me in completing my macro.

I have a scenario where in I have to select some random samples from the data dump, Please provide me a VBA code which I can insert in my macro.
Below is the criteria:


Name Day Count of Samples Task Categories
Sandeep Emmidi Monday 5 Sales
Naveen K Ramu Tuesday 5 Purchase

Based on above table the macro should check the current day, if it is Monday then the code should copy 5 samples of P/L category from dump and copy those random samples in to new excel file

I have attached the dump data for reference

 

[Ranman256]

'you need a form, on the form are text boxes for the criteria. txtName, txtSample, etc.
'a listbox holds all these persons and sample sizes.
'when you click the start button, it runs this code. It cycles thru the list box of all records needed.
'gets a person, fills in the listboxes of the data wanted,
'then the query, qsDataFromListbox, pulls this data using what's in the text box.
'the next loop marks the the field: MARKED, by pulling random records

Public Sub RandomSamples()
Dim sSql As String
Dim rst As Recordset, itm
Dim vName, vCnt, vTask, vCata
Dim i As Integer, iSample As Integer, iMarked As Integer, r As Integer
Dim iTotRecs As Long

DoCmd.SetWarnings False
For i = 0 To lstBox.ListCount - 1
    itm = lstBox.ItemData(i)  'get value in list
    lstBox = itm              'move the list box to the next item in list
       
       'fill in text boxes on form for query to use
    txtName = lstBox.Column(0)
    txtSample = lstBox.Column(1)
    txtDay = lstBox.Column(2)
    txtCata = lstBox.Column(3)
    
    Set rst = CurrentDb.OpenRecordset("qsDataFromListbox")  'get the records for the 1 person in listbox
        'qsDataFromListbox pulls data from the main data table based on the items in the listbox
        'person, day, catagory all are in the text boxes
    
    iSample = txtSample   'get the count of samples needed for this person
    iTotRecs = .RecordCount   'total recs this person has
    
    iMarked = 0
    With rst
       If iTotRecs <= iCnt Then
           'mark all records
           DoCmd.OpenQuery "quMarkAllRecords"
       Else
          While iMarked <= iSample
             .MoveFirst
             r = Int(iTotRecs * Rnd) + 1
             .Move r - 1
             
              'mark 1 random record
              If .Fields("Marked").Value = False Then
                  .Fields("Marked").Value = True
                  iMarked = iMarked + 1
              End If
          Wend
       End If
    End With
    
        'export the marked records using the query qsXportMarkedRecs
        
    vFile = "c:\folder\" & txtName & ".xlsx"
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "qsXportMarkedRecs", vFile, True, "Sample"
Next
Set rst = Nothing
DoCmd.SetWarnings True
End Sub

Public Sub RandomSamples()
Dim sSql As String
Dim rst, itm
Dim vName, vCnt, vTask, vCata
Dim i As Integer, iSample As Integer, iMarked As Integer, r As Integer
Dim iTotRecs As Long

DoCmd.SetWarnings False
For i = 0 To lstBox.ListCount - 1
    itm = lstBox.ItemData(i)  'get value in list
    lstBox = itm              'move the list box to the next item in list
       
       'fill in text boxes on form for query to use
    txtName = lstBox.Column(0)
    txtSample = lstBox.Column(1)
    txtDay = lstBox.Column(2)
    txtCata = lstBox.Column(3)
    
    Set rst = CurrentDb.OpenRecordset("qsDataFromListbox")  'get the records for the 1 person in listbox
        'qsDataFromListbox pulls data from the main data table based on the items in the listbox
        'person, day, catagory all are in the text boxes
    
    iSample = txtSample   'get the count of samples needed for this person
    iTotRecs = .RecordCount   'total recs this person has
    
    iMarked = 0
    With rst
       If iTotRecs <= iCnt Then
           'mark all records
           DoCmd.OpenQuery "quMarkAllRecords"
       Else
          While iMarked <= iSample
             r = Int(iTotRecs * Rnd) + 1
             
              'mark 1 random record
              If .Fields("Marked").Value = False Then
                  .Fields("Marked").Value = True
                  iMarked = iMarked + 1
              End If
          Wend
       End If
    End With
    
        'export the marked records using the query qsXportMarkedRecs
        
    vFile = "c:\folder\" & txtName & ".xlsx"
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "qsXportMarkedRecs", vFile, True, "Sample"
Next
Set rst = Nothing
DoCmd.SetWarnings True
End Sub