VBA code to pick data based on multiple conditions

[tirumal]

Hello guys,



I've been struggling to write this for days macro and I have finally decided to ask for your help.


Here's what I have:



Sheet1 - Job IDs, Assignees and Tasks as headers



A1 - IDs

B1 - Assignees

C1 - Tasks

*Rest of the columns are something i've tried which did not work out.



There are different no. of Jobs in the data and each job has 2 tasks only. The tasks (task1 and task2) of each job are done by either 2 assignees separately or done by the same assignee (for some jobs).



What I am trying to achieve:



- I want to filter data in such a way that the macro should pick only five task1's and task2's of each assignee.

- But ideally, when a task2 of a job is picked, task 1 of the same job should also be picked keeping in mind that the assignee that did that task did not have more than 5 task1;s (or) task2's picked.

- My idea is, the macro should be able to ideally keep a log or delete data no. of tasks of a particular assignee once they reach the threshold of 5.

- To put it in simple terms, the no. of jobs picked do not matter, but both task 1 and 2 of any Job should be picked and each assignee should equally have 5 task1 and task2's.



I had multiple attempts but I have failed miserably. I would be really grateful if someone helps me out.

*Please find the file link here

Thank you,
Tirumal

 

[tirumal]

Sure,
I'll be waiting

 

[Yongle]

The code assumes that your data is 3 columns wide and is in columns A:C in sheet 1
The data is sorted by Job and both tests for each job are allocated at the same time
Results areplaced in a new sheet

Test on a copy of your data!
Put the all the code in ONE module
amend sheet name if different (see SetRanges)

    Set ws1 = Sheets("Sheet1")

and run AllocateJobID

Option Explicit
Dim wf As WorksheetFunction
Dim ID As Range, ID2 As String, Mgr1 As String, Opt1 As String, Mgr2 As String, Opt2 As String, msg As String
Dim A As Range, B As Range, C As Range
Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, lastR As Long, r As Long

Sub AllocateJobID()
    Application.ScreenUpdating = False
    SetWorksheets
    SortData
    For r = 2 To lastR Step 2
        SetRanges
        msg = TestValues
        If msg <> "" Then GoTo Problem
         
        If wf.CountIfs(B, Mgr1, C, Opt1) < 6 And wf.CountIfs(B, Mgr2, C, Opt2) < 6 Then
            rng.Value = Array(ID, Mgr1, Opt1)
            rng.Offset(1).Value = Array(ID2, Mgr2, Opt2)
        End If
    Next r
Exit Sub

Problem: MsgBox msg & vbCr & "rows " & r & " and " & r + 1
End Sub

Private Sub SetWorksheets()
    Set wf = WorksheetFunction
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets.Add(after:=ws1)
    With ws2
        Set A = .Range("A:A")
        Set B = .Range("B:B")
        Set C = .Range("C:C")
    End With
 
    lastR = ws1.Range("A" & Rows.Count).End(xlUp).Row
End Sub

Private Sub SetRanges()
    Set ID = ws1.Cells(r, 1)
    With ID
        ID2 = .Offset(1)
        Mgr1 = .Offset(, 1)
        Opt1 = .Offset(, 2)
        Mgr2 = .Offset(1, 1)
        Opt2 = .Offset(1, 2)
    End With
    Set rng = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3)
End Sub

Private Function TestValues() As String
    If ID <> ID2 Then TestValues = "ID does not match"
    If Opt1 = Opt2 Then TestValues = "True/False Issue"
End Function

Private Sub SortData()
    With ws1.Sort.SortFields
        .Clear
        .Add Key:=Range("A:A"), Order:=xlAscending
        .Add Key:=Range("C:C"), Order:=xlAscending
    End With
    With ws1.Sort
       .SetRange Range("A:C")
       .Header = xlYes
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
    End With
End Sub

 

[tirumal]

Where should i use this
Set ws1 = Sheets("Sheet1")

 

[tirumal]

I've set the threshold to <=49 which is returning 50 IDs
And in some parts the distribution is unequal even though they have enought samples

for example:

Allocation test.xlsm
	A	B	C	D
17	saithom	50	50	100
18	blbi	50	50	100
19	shprakha	50	50	100
20	chatuadi	50	50	100
21	snghoj	50	50	100
22	glenmart	50	50	100
23	mtshah	50	50	100
24	wajakhan	48	50	98
25	sattili	48	50	98
26	abbaksh	47	50	97
27	tulap	40	50	90
28	sshaka	39	50	89
29	mnallan	37	50	87
30	vnchan	36	50	86
31	elisaty	36	50	86
32	siaditi	50	34	84
33	nikumark	50	34	84
34	smantral	41	39	80
35	mamidih	33	37	70
36	estrb	42	28	70
37	mohaaimr	22	9	31
38	abhyud	9	4	13
39	sammula	10	1	11
40	rogelios		2	2
41	Grand Total	1538	1538	3076
Sheet9

And if you check the last guy he only has 2 True samples but no false samples taken.
I want to understand at to why this is happening and what's causing it?
Is it the data in itself?

 

[Yongle]

1. You did not mention a threshold - I expected you to run the code against all the data
Try running the code against all the data and let me know

2. Several Job ID's are probably being rejected because ONE of the TWO assignee has already reached the limit of either 5 TRUE or 5 FALSE values when VBA checks the count
- currently the data is sorted by Job
- It may be beneficial to sort the data differently so that those with smallest number of jobs are allocated first
- the code will unfortunately take longer to run
- we can test that tomorrow after you have allowed the code to run against all the data

 

[tirumal]

1. You did not mention a threshold - I expected you to run the code against all the data
Try running the code against all the data and let me know

2. Several Job ID's are probably being rejected because ONE of the TWO assignee has already reached the limit of either 5 TRUE or 5 FALSE values when VBA checks the count
- currently the data is sorted by Job
- It may be beneficial to sort the data differently so that those with smallest number of jobs are allocated first
- the code will unfortunately take longer to run
- we can test that tomorrow after you have allowed the code to run against all the data

1. I need this execution by tomorrow, so I'm trying the best to understand it and have no discrepancies with it.
2. There is NO threshold, the code is running against all the data. I've just changed the 5 true and false condition to 49, which is returning 50 True and False values to each Manager. (In the REAL data i want the same <=50 Values of both True and False. since not all the managers might have 50 True/False values).

i changed it here:

If wf.CountIfs(B, Mgr1, C, Opt1) <= 49 And wf.CountIfs(B, Mgr2, C, Opt2) <= 49 Then

//Why should i set it to 49 for getting 50 values by the way?

3.Yeah, i think is better to sort smallest number of jobs first so there will be equal distribution.
4. Also, where shall i use this piece of code - Set ws1 = Sheets("Sheet1")

 

[Yongle]

1. I need this execution by tomorrow, so I'm trying the best to understand it and have no discrepancies with it.

as a volunteer I feel no such pressure
If you want no further help tomorrow that is fine - just let me know

 

[tirumal]

as a volunteer I feel no such pressure
If you want no further help tomorrow that is fine - just let me know

Thank you for the help Mr. Yongle
This really made my day. I was extremely happy to see the code work as expected.

Can you let me know how to sort the data with smaller numbers first? This would really finish the job.

And as a final request, i would want to understand the code to be able to make any changes in the future. It would be really helpful if you mentioned the code comments.

 

[tirumal]

Hi Yongle,

Can you please help me out on sorting out the smallest number of jobs first?

 

[Yongle]

Here you go, test this

The code is now more complicated because the 2 lines for each job are not adjacent to each other
- now having to find the other entry each time

Option Explicit
Dim wf As WorksheetFunction
Dim ID As Range, ID2 As Range, Mgr1 As String, Opt1 As String, Mgr2 As String, Opt2 As String, msg As String
Dim A1 As Range, B1 As Range, C1 As Range, A2 As Range, B2 As Range, c2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, lastR As Long, r As Long

Sub AllocateJobID()
    Application.ScreenUpdating = False
    SetWorksheetsAndRanges
    AddCountInColumnD
    SortSourceData
    ws1.Columns("D").ClearContents

    For r = 2 To lastR - 1
        Set ID = ws1.Cells(r, 1)
        If wf.CountIf(A1, ID) = 2 Then                          '(ensures 2 values available for Job No)
            If wf.CountIf(A2, ID) = 0 Then                      '(ensures Job No not already in results)
                PairUpJobRows
                    If wf.CountIfs(B2, Mgr1, c2, Opt1) < 5 And wf.CountIfs(B2, Mgr2, c2, Opt2) < 5 Then         '(limit on number of values)
                        rng.Value = Array(ID, Mgr1, Opt1, r)
                        rng.Offset(1).Value = Array(ID2, Mgr2, Opt2)
                    Else
                        'Debug.Print "failed CountIf",r, ID, Mgr1, Opt1
                        'Debug.Print "failed CountIf",r, ID2, Mgr2, Opt2
                    End If
            End If
        End If
    Next r
Exit Sub

Problem: MsgBox msg
End Sub

Private Sub SetWorksheetsAndRanges()
    Set wf = WorksheetFunction
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets.Add(after:=ws1)
    lastR = ws1.Range("A" & Rows.Count).End(xlUp).Row
    Set A1 = ws1.Range("A:A")
    Set B1 = ws1.Range("B:B")
    Set C1 = ws1.Range("C:C")
    Set A2 = ws2.Range("A:A")
    Set B2 = ws2.Range("B:B")
    Set c2 = ws2.Range("C:C")
End Sub

Private Sub PairUpJobRows()
'get value for each Job No and find its twin row
    Mgr1 = ID.Offset(, 1)
    Opt1 = ID.Offset(, 2)
    Set ID2 = A1.Find(ID, after:=ID.Offset(1))      'find 2nd task for Job No
    Mgr2 = ID2.Offset(1, 1)
    Opt2 = ID2.Offset(1, 2)
    Set rng = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3)
End Sub

Private Sub AddCountInColumnD()
'this is required to enable sort on assisnee count
    For r = 2 To lastR
        With ws1
            .Cells(r, "D") = wf.CountIfs(B1, .Cells(r, "B"), C1, .Cells(r, "C"))
        End With
    Next r
End Sub

Private Sub SortSourceData()
'attempt to get data in bestsequence
    ws1.Sort.SortFields.Clear
    With ws1.Range("A2:D" & lastR)
        .Sort Key1:=ws1.Range("B2"), Order1:=xlAscending, Header:=xlNo
        .Sort Key1:=ws1.Range("C2"), Order1:=xlAscending, Header:=xlNo
        .Sort Key1:=ws1.Range("D2"), Order1:=xlAscending, Header:=xlNo
    End With
End Sub

I will explain Debug.Print to you in a few minutes