jawaharprm
Member
Hi Team,
i got a code for random allocation and made some modification as per my requirement, but the output is not proper.
in D Column need to filter only "9" and in N column there are many users i need to take 10% of user count and need to allocate some person in column P
Example - if user1 has total count of 24 only 2 request has to allocate to "person A to E" if 37 only 4 request has to be allocate, if <10 only 1 request has to allocate, and all the 5 "Person A-E" should be get allocation @ P Column. i enclosed sample file for reference.
Thanks
Jawahar
i got a code for random allocation and made some modification as per my requirement, but the output is not proper.
in D Column need to filter only "9" and in N column there are many users i need to take 10% of user count and need to allocate some person in column P
Example - if user1 has total count of 24 only 2 request has to allocate to "person A to E" if 37 only 4 request has to be allocate, if <10 only 1 request has to allocate, and all the 5 "Person A-E" should be get allocation @ P Column. i enclosed sample file for reference.
Code:
Option Explicit
Sub AllocateUsersBasedOnPercentage()
Dim ws As Worksheet
Dim lastRow As Long
Dim uniqueUsers As Collection
Dim user As Variant
Dim userCounts As Object
Dim personNames As Variant
Dim personIndex As Integer
Dim allocationCount As Integer
Dim i As Long, j As Integer
Dim currentRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
' 5 person name to be allocated in P column
personNames = Array("Person A", "Person B", "Person C", "Person C", "Person E")
If ws.AutoFilterMode Then ws.AutoFilterMode = False
ws.Range("A1:O" & lastRow).AutoFilter Field:=4, Criteria1:="9"
'Collecting unique user in N Column
Set uniqueUsers = New Collection
Set userCounts = CreateObject("Scripting.Dictionary")
On Error Resume Next
For i = 2 To lastRow
If ws.Rows(i).Hidden = False Then
user = ws.Cells(i, "N").Value
If user <> "" Then
If Not userCounts.Exists(user) Then
uniqueUsers.Add user
userCounts.Add user, 0
End If
userCounts(user) = userCounts(user) + 1
End If
End If
Next i
On Error GoTo 0
ws.AutoFilterMode = False
'Allocate users based on 10% rule
currentRow = 2
For Each user In uniqueUsers
allocationCount = Application.WorksheetFunction.RoundUp(userCounts(user) * 0.1, 0)
' Ensure at least one allocation if count is < 10
If userCounts(user) < 10 Then allocationCount = 1
personIndex = 0
For j = 1 To allocationCount
ws.Cells(currentRow, "N").Value = user
ws.Cells(currentRow, "P").Value = personNames(personIndex)
personIndex = (personIndex + 1) Mod 5 ' Rotate through the names
currentRow = currentRow + 1
Next j
Next user
End SubThanks
Jawahar
