Updating records using Top 55% or Random function VBA (1 Viewer)

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
Hi Guys

My challenge is to quarterly allocate various activities (e.g Call audits, Staff reviews,meetings etc..) for the staff members. Sometimes there are 2 or 3 activities to be taken place quarterly for the some of the staff members.

So I have done the following and need your help in updating the 'MonthRef' field.

I have inserted few records for the staff members in a table and now I want to run update query that will pick first 55% of the records and update 'MonthRef' field to first quarter of the year (i.e Jan) and then it will update 55% of the remaining records and 'MonthRef' field is set to 'May' . And then it will update the remaining records in the table and the 'MonthRef' field is set to 'Sep'.

This is the first alternative to get this done, the other one could be using Random function and update 'MonthRef' field.

Can anyone please help me in this?

Regards,
 

The_Doc_Man

Immoderate Moderator
Staff member
Local time
Yesterday, 20:32
Joined
Feb 28, 2001
Messages
27,001
Other than the idea of asking for 110% (=55%+55%) of your worker's efforts (which sounds like every other management team I've ever seen), there are several ways of doing this.

Look up the SQL syntax of the TOP keyword. You can do a

Code:
SELECT TOP n field-list FROM table;

Then the only issue is perhaps a DCount or other method to count the total number of records and then compute the "n" that will represent 55% of that count. You MIGHT wish to consider including a flag in the record since you are doing a "compound interest" problem in a sense. You want 55% of the total, then 55% of the remainder, then the remainder. The EASIEST way to do that is, when you select your first 55%, be sure to mark them. Then when you compute the next 55%, do so only from the pool of unmarked (i.e. ... WHERE MARKFLAG=FALSE ...). Then the final set is simply anything that hasn't been marked yet.
 

CJ_London

Super Moderator
Staff member
Local time
Today, 01:32
Joined
Feb 19, 2013
Messages
16,553
further to Docs post, you can use

SELECT TOP 55% ….
 

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
Guys, Please see attached the spreadsheet with some data, I want to update the records so that MonthRef field is assigned with random month of the quarter. My code below updates the records using top 55 percent but it's not right (Looking at the Staff member field values) as same staff member will be given same month to carry out various activities . Can you please amend the code to make it working?
Code:
Public Sub QuarterlyAllocation()
Dim rs1 As Recordset
Dim rs2 As Recordset
Dim rs3 As Recordset

Dim dtmStaffRef As String

Set rs1 = CurrentDb.OpenRecordset("SELECT * FROM tblStaff WHERE RoleRef in (37) AND [DateEnd] is Null")

Set rs3 = CurrentDb.OpenRecordset("tbl_Mas_Allocation")

If rs1.RecordCount = 0 Then
    'if no staff then no further action required
Else

rs1.MoveLast
rs1.MoveFirst

Do Until rs1.EOF

dtmStaffRef = rs1![strUser]
   
Set rs2 = CurrentDb.OpenRecordset("tbl_Ref_Standard")

If rs2.RecordCount = 0 Then
            'if no parameters then no further action required
Else
   rs2.MoveLast
   rs2.MoveFirst
   
   Do Until rs2.EOF
      
      If rs2.Fields("FrequencyRef") = 4 Then ' It means quarterly

         For i = 0 To rs2.Fields("Number")   ' how many activities in total

         With rs3
             
             .AddNew
             .Fields("SupRef") = NameofUser()
             .Fields("StaffRef") = dtmStaffRef
             .Fields("ActivityRef") = rs2.Fields("ActivityRef")
           '  .Fields("MonthlyRef") = DateSerial(Year(Date), Month(Date), 1)
             .Fields("Flag") = True
             .Update
         
         End With
         
         Next i
         
       End If
       
       rs2.MoveNext
    Loop
    
End If

rs1.MoveNext
Loop
End If

Set rs1 = Nothing
Set rs2 = Nothing
Set rs3 = Nothing

Dim strsql As String

'Update records - Assign months of 1st quarter 

' Month -  January

strsql = "Select Top 55 Percent * from tbl_Mas_Allocation where Flag=True"

Set rs1 = CurrentDb.OpenRecordset(strsql)
rs1.MoveFirst

Do While Not rs1.EOF
With rs1
.Edit
.Fields("Flag") = False
'.Fields("MonthRef") = DateSerial(Year(Date), Month(Date), 1)
.Fields("Month_Name") = "Jan"
.Update
End With
rs1.MoveNext
Loop

Set rs1 = Nothing

' Month - Feb

strsql = "Select Top 55 Percent * from tbl_Mas_Allocation where Flag=True"

Set rs1 = CurrentDb.OpenRecordset(strsql)
rs1.MoveFirst

Do While Not rs1.EOF
With rs1
.Edit
.Fields("Flag") = False
'.Fields("MonthRef") = DateSerial(Year(Date), Month(Date), 1)
.Fields("Month_Name") = "Feb"
.Update
End With
rs1.MoveNext
Loop

Set rs1 = Nothing


' Month - March

strsql = "Select * from tbl_Mas_Allocation where Flag=True"

Set rs1 = CurrentDb.OpenRecordset(strsql)
rs1.MoveFirst

Do While Not rs1.EOF
With rs1
.Edit
.Fields("Flag") = False
'.Fields("MonthRef") = DateSerial(Year(Date), Month(Date), 1)
.Fields("Month_Name") = "Mar"
.Update
End With
rs1.MoveNext
Loop

Set rs1 = Nothing

End Sub
 

Attachments

  • DataSheet.xlsx
    10.2 KB · Views: 114
Last edited:

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
Guys instead of using TOP 55 PERCENT , Can we use random function to update records ? Basically we need validation to check if its first quarter and if Flag=true then update randomely 'MonhRef' field to Jan/Feb/Mar.

For second quarter the MonRef field will be updated to Apr/May/Jun

and so on for other quarters.

Can anyone please change the code to me it working ?
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 09:32
Joined
May 7, 2009
Messages
19,169
here maybe something like this:
Code:
...
...
    Dim Dt As Date
    For i = 0 To rs2.Fields("Number")   ' how many activities in total
        Dt = CDate(fncRandom(i))
         With rs3
             
             .AddNew
             .Fields("SupRef") = NameofUser()
             .Fields("StaffRef") = dtmStaffRef
             .Fields("ActivityRef") = rs2.Fields("ActivityRef")
           '  .Fields("MonthlyRef") = DateSerial(Year(Date), Month(Date), 1)
             .Fields("MonthlyRef") = Format(Dt, "mmm")
             .Fields("Flag") = True
             .Update
         
         End With
         
         Next i
...
...
Code:
Public Function fncRandom(intStart As Integer)
    Static strDates As String
    Dim strDt As String
    If intStart = 0 Then strDates = ""
    Randomize
    strDt = Format(Rnd(12) + 1, "00") & "/01" & Year(Date)
    If strDates <> "" Then
        While InStr(strdsates, strDt) <> 0
                strDt = Format(Rnd(12) + 1, "00") & "/01" & Year(Date)
        Wend
    End
    strDates = "/" & strDt

    fncRandom = strDt
End Function
 

MajP

You've got your good things, and you've got mine.
Local time
Yesterday, 21:32
Joined
May 21, 2018
Messages
8,463
Here is another version. You can specify a date or use the current date.

Code:
Public Function GetRandomMonthInQuarter(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim Qtr As Integer
  Dim RandMonth
  Dim randDate
  Dim TheYear As Integer

  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  'May have to adjust QTR function if talking FY vs CY
  Qtr = CInt(Format(Date, "Q"))
  Randomize
  RandMonth = Int(Rnd * 3) + 1
  Select Case Qtr
    Case 1
      randDate = DateSerial(TheYear, RandMonth, 1)
    Case 2
      randDate = DateSerial(TheYear, RandMonth + 3, 1)
    Case 3
      randDate = DateSerial(TheYear, RandMonth + 6, 1)
    Case 4
      randDate = DateSerial(TheYear, RandMonth + 9, 1)
 End Select
 GetRandomMonthInQuarter = randDate
End Function

You can also use this in a query but you have to pass in a unique value for each record. like a PK. If you do not the function will run only once for all records. Also you only need to store the returned date not the month name then format it in a query like. Select "QTR" & format([Randdate],"Q") AS TheQuarter
 

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
Arnelgp, there is End if statement missing . I'm getting an error message . Where do i need to put it?
here maybe something like this:

Code:
Public Function fncRandom(intStart As Integer)
    Static strDates As String
    Dim strDt As String
    If intStart = 0 Then strDates = ""
    Randomize
    strDt = Format(Rnd(12) + 1, "00") & "/01" & Year(Date)
    If strDates <> "" Then
        While InStr(strdsates, strDt) <> 0
                strDt = Format(Rnd(12) + 1, "00") & "/01" & Year(Date)
        Wend
    End
    strDates = "/" & strDt

    fncRandom = strDt
End Function
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 09:32
Joined
May 7, 2009
Messages
19,169
replace the last End with End If
 

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
I'm getting Type mismatch error at below line. The value of i could be from 1 to 4 (this shows how many times the activity will take place quarterly for a staff member)
Code:
   Dt = CDate(fncRandom(i))

replace the last End with End If
 

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
Thanks MajP, it works great. How can i amend the code so that it will pick random month in half year and also randon month in a year?
Many Thanks
Here is another version. You can specify a date or use the current date.

Code:
Public Function GetRandomMonthInQuarter(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim Qtr As Integer
  Dim RandMonth
  Dim randDate
  Dim TheYear As Integer

  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  'May have to adjust QTR function if talking FY vs CY
  Qtr = CInt(Format(Date, "Q"))
  Randomize
  RandMonth = Int(Rnd * 3) + 1
  Select Case Qtr
    Case 1
      randDate = DateSerial(TheYear, RandMonth, 1)
    Case 2
      randDate = DateSerial(TheYear, RandMonth + 3, 1)
    Case 3
      randDate = DateSerial(TheYear, RandMonth + 6, 1)
    Case 4
      randDate = DateSerial(TheYear, RandMonth + 9, 1)
 End Select
 GetRandomMonthInQuarter = randDate
End Function

You can also use this in a query but you have to pass in a unique value for each record. like a PK. If you do not the function will run only once for all records. Also you only need to store the returned date not the month name then format it in a query like. Select "QTR" & format([Randdate],"Q") AS TheQuarter
 

MajP

You've got your good things, and you've got mine.
Local time
Yesterday, 21:32
Joined
May 21, 2018
Messages
8,463
Here is a more generic random range function. This will give you a random integer between a lower and upper bound.

Code:
Public Function GetRandomRange(UpperBound, Optional LowerBound = 0, Optional RandomizeSeries = True)
  'If you do not randomize then you will get the same series of random numbers on each opening of the Application
  If RandomizeSeries Then Randomize
  GetRandomRange = Int((UpperBound - LowerBound + 1) * Rnd + LowerBound)
End Function

So with that you can easily modify the quarters function

Code:
Public Function GetRandomMonthInQuarter(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim Qtr As Integer
  Dim RandMonth
  Dim randDate
  Dim TheYear As Integer

  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  'May have to adjust QTR function if talking FY vs CY
  Qtr = CInt(Format(Date, "Q"))
  Randomize
  RandMonth = GetRandomRange(3, 1)
  Select Case Qtr
    Case 1
      randDate = DateSerial(TheYear, RandMonth, 1)
    Case 2
      randDate = DateSerial(TheYear, RandMonth + 3, 1)
    Case 3
      randDate = DateSerial(TheYear, RandMonth + 6, 1)
    Case 4
      randDate = DateSerial(TheYear, RandMonth + 9, 1)
 End Select
 GetRandomMonthInQuarter = randDate
End Function

Public Function GetRandomMonth(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim RandMonth
  Dim TheYear As Integer
  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  RandMonth = GetRandomRange(12, 1)
  GetRandomMonth = DateSerial(TheYear, RandMonth, 1)
End Function

Public Function GetRandomMonthInHalfYear(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim RandMonth As Integer
  Dim LowerBound As Integer
  Dim UpperBound As Integer
  Dim TheYear As Integer
  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  If Month(TheDate) < 7 Then
    UpperBound = 6
    LowerBound = 1
  Else
    UpperBound = 12
    LowerBound = 7
  End If
  RandMonth = GetRandomRange(UpperBound, LowerBound)
  GetRandomMonthInHalfYear = DateSerial(TheYear, RandMonth, 1)
End Function
 

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
That's great MajP. Many Thanks. Sometimes it gives the same month for various activities to be completed by the same person. Can we avoid that?
 

MajP

You've got your good things, and you've got mine.
Local time
Yesterday, 21:32
Joined
May 21, 2018
Messages
8,463
Not sure if I understand what you are trying to do and how you are doing it. If a person has 10 activities to do and we want to randomly assign a month to each activity, but no repeats of months I need to get a list of 10 different months in random order. Then once you got the random list you would assign those in order to the ten tasks.

Code:
Public Function GetRandomMonthsNoRepeats(MonthsNeeded As Integer, Optional TheDate As Date) As Collection
    Dim coll As New Collection
    Dim MonthReturn As Date
    Dim i As Integer
    Dim blnFound As Boolean
    If TheDate = 0 Then TheDate = Date
    If MonthsNeeded > 12 Then MonthsNeeded = 12
    'Add the first item to collection
    coll.Add GetRandomMonth(TheDate)
    Do
      MonthReturn = GetRandomMonth(TheDate)
       For i = 1 To coll.Count
         If coll(i) = MonthReturn Then
          blnFound = True
          Exit For
        End If
      Next i
        If Not blnFound Then coll.Add MonthReturn
        blnFound = False
    Loop Until coll.Count = MonthsNeeded
    Set GetRandomMonthsNoRepeats = coll
End Function

You would call it something like

Code:
Public Sub TestRand()
  Dim i As Integer
  Dim coll As Collection
  Set coll = GetRandomMonthsNoRepeats(10)
  For i = 1 To 10
    Debug.Print i & " " & coll(i)
    'Some update query here to assign your tasks
  Next i
End Sub

Output
Code:
1 11/1/2018
2 8/1/2018
3 7/1/2018
4 6/1/2018
5 10/1/2018
6 3/1/2018
7 2/1/2018
8 5/1/2018
9 9/1/2018
10 4/1/2018
 

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
Thanks MajP, How can we amend the following code so that there is no repitition of months?
Code:
Public Sub AllocateQuarterlyActivities()

'Working Procedure

Dim rs1 As Recordset
Dim rs2 As Recordset
Dim rs3 As Recordset
Dim Dt As Date
Dim i As Integer
Dim dtmStaffRef As String

Set rs1 = CurrentDb.OpenRecordset("SELECT * FROM tblStaff WHERE RoleRef in (37) AND [DateEnd] is Null")

Set rs3 = CurrentDb.OpenRecordset("tblAllocation")

If rs1.RecordCount = 0 Then
    'if no staff then no further action required
Else

rs1.MoveLast
rs1.MoveFirst

Do Until rs1.EOF

dtmStaffRef = rs1![strUser]
   
Set rs2 = CurrentDb.OpenRecordset("select * from tblMatrix where FrequencyRef=4 and Active=True")

If rs2.RecordCount = 0 Then
            'if no parameters then no further action required
Else
   rs2.MoveLast
   rs2.MoveFirst
   
   Do Until rs2.EOF
      
       For i = 1 To rs2.Fields("Number")
          
          With rs3
             
             .AddNew
             .Fields("SupRef") = NameofUser()
             .Fields("StaffRef") = dtmStaffRef
             .Fields("ActivityRef") = rs2.Fields("ActivityTypeRef")
             .Fields("MonthRef") = GetRandomMonthInQuarter(Date, rs3.Fields("AllocationID"))
             .Update
         
         End With
         
       Next i
         
     
       rs2.MoveNext
    
   Loop
   
    
End If

rs1.MoveNext

Loop

DoCmd.SetWarnings False
DoCmd.RunSQL "Update tblMatrix set Active=False where FrequencyRef=4"
DoCmd.SetWarnings True

End If

Set rs1 = Nothing
Set rs2 = Nothing
Set rs3 = Nothing

End Sub
 

aman

Registered User.
Local time
Yesterday, 18:32
Joined
Oct 16, 2008
Messages
1,250
I am looking for functions that will display random months (No repetition for same staff) in a quarter, Half year and annual.

I hope anyone can help me with this. Thanks
 

MajP

You've got your good things, and you've got mine.
Local time
Yesterday, 21:32
Joined
May 21, 2018
Messages
8,463
You need to look two posts back. I provided the answer in a function called GetRandomMonthsNoRepeats.
 

MajP

You've got your good things, and you've got mine.
Local time
Yesterday, 21:32
Joined
May 21, 2018
Messages
8,463
I guess you need the fish. Here are all the previous functions.
Code:
Public Function GetRandomMonthInQuarter(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim Qtr As Integer
  Dim RandMonth
  Dim randDate
  Dim TheYear As Integer

  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  'May have to adjust QTR function if talking FY vs CY
  Qtr = CInt(Format(Date, "Q"))
  Randomize
  RandMonth = GetRandomRange(3, 1)
  Select Case Qtr
    Case 1
      randDate = DateSerial(TheYear, RandMonth, 1)
    Case 2
      randDate = DateSerial(TheYear, RandMonth + 3, 1)
    Case 3
      randDate = DateSerial(TheYear, RandMonth + 6, 1)
    Case 4
      randDate = DateSerial(TheYear, RandMonth + 9, 1)
 End Select
 GetRandomMonthInQuarter = randDate
End Function
Public Function GetRandomMonthinYear(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim RandMonth
  Dim TheYear As Integer
  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  RandMonth = GetRandomRange(12, 1)
  GetRandomMonthinYear = DateSerial(TheYear, RandMonth, 1)
End Function
Public Function GetRandomMonthInHalfYear(Optional TheDate As Date, Optional UniqueKey As Variant) As Date
  'Need to pass in a unique key per record if you want to use in a query
  Dim RandMonth As Integer
  Dim LowerBound As Integer
  Dim UpperBound As Integer
  Dim TheYear As Integer
  If TheDate = 0 Then TheDate = Date
  TheYear = Year(TheDate)
  If Month(TheDate) < 7 Then
    UpperBound = 6
    LowerBound = 1
  Else
    UpperBound = 12
    LowerBound = 7
  End If
  RandMonth = GetRandomRange(UpperBound, LowerBound)
  GetRandomMonthInHalfYear = DateSerial(TheYear, RandMonth, 1)
End Function

Public Function GetRandomRange(UpperBound, Optional LowerBound = 0, Optional RandomizeSeries = True)
  'If you do not randomize then you will get the same series of random numbers on each opening of the Application
  If RandomizeSeries Then Randomize
  GetRandomRange = Int((UpperBound - LowerBound + 1) * Rnd + LowerBound)
End Function

All you have to do is wrap them in another function

Code:
Public Function GetRandomMonthsNoRepeats(Optional MonthIn As RandomMonthIn = rYear, Optional TheDate As Date = 0) As Collection
    Dim coll As New Collection
    Dim MonthReturn As Date
    Dim i As Integer
    Dim blnFound As Boolean
    Dim NoOfMonths As Integer
    If TheDate = 0 Then TheDate = Date
  
    'Add the first item to collection
    Select Case MonthIn
      Case rQTR
        coll.Add GetRandomMonthInQuarter(TheDate)
        NoOfMonths = 3
      Case rSemi
        coll.Add GetRandomMonthInHalfYear(TheDate)
        NoOfMonths = 6
      Case rYear
        coll.Add GetRandomMonthinYear(TheDate)
        NoOfMonths = 12
    End Select
    Do
      Select Case MonthIn
      Case rQTR
        MonthReturn = GetRandomMonthInQuarter(TheDate)
      Case rSemi
        MonthReturn = GetRandomMonthInHalfYear(TheDate)
      Case rYear
        MonthReturn = GetRandomMonthinYear(TheDate)
      End Select
      For i = 1 To coll.Count
         If coll(i) = MonthReturn Then
          blnFound = True
          Exit For
        End If
      Next i
        If Not blnFound Then coll.Add MonthReturn
        blnFound = False
    Loop Until coll.Count = NoOfMonths
    Set GetRandomMonthsNoRepeats = coll
End Function

and at the very top of the module add
Code:
Public Enum RandomMonthIn
  rQTR = 0
  rSemi = 1
  rYear = 2
End Enum

So to test it
Code:
Public Sub TestRand()
  Dim i As Integer
  Dim coll As Collection
  
  Set coll = GetRandomMonthsNoRepeats(rYear, Date)
  For i = 1 To coll.Count
    Debug.Print i & " " & coll(i)
  Next i
End Sub
if you pass in rYear you will get 12 random months no repeats
if you pass in rSemi you will get 6 random months no repeats
if you pass in rQtr you will get 3 random months no repeats
 

MajP

You've got your good things, and you've got mine.
Local time
Yesterday, 21:32
Joined
May 21, 2018
Messages
8,463
More precisely:
if you pass in rYear you will get 12 random months within the given year no repeats
if you pass in rSemi you will get 6 random months within the given half year no repeats
if you pass in rQtr you will get 3 random months within the given quarter no repeats
 

Users who are viewing this thread

Top Bottom