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

 

[Yongle]

Ah - worked it out
Data filter was already enabled on my sheet1 - so that was copied across when sheet copied - oops!

Insert this
.Range("A1").AutoFilter

Above
.Range("A1:A" & lastR).AutoFilter Field:=3, Criteria1:=FALSE


- the dot( . ) does that
- the code is correct

If for any reason the code is not working now, paste amended "CreateNewLayout" in full into your reply

 

[tirumal]

If for any reason the code is not working now, paste amended "CreateNewLayout" in full into your reply

Sure! will update in case if any

 

[tirumal]

Now which code should i run on this sorted data?

 

[Yongle]

When back at my PC I will explain next steps

 

[tirumal]

When back at my PC I will explain next steps

How long can it take?
I'm very curious to see the results ?

 

[Yongle]

Delete prior code

In this code
- columns B & C are copied to D & E
- rejected rows are marked by clearing values in D & E
- at end all rows with nothing in column E are removed
- temporary data in D & E then deleted

Test this to see if you can make it yield results closer to what you want
- your problem is a classic "chicken and egg" scenario
- additional rules can be added to remove rows based on different criteria etc

I will post code tomorrow to output result in original format

Option Explicit

Dim wf As WorksheetFunction
Dim ID As Range, mT As Range, mF As Range, mT2 As Range, mF2 As Range
Dim A2 As Range, B2 As Range, C2 As Range, D2 As Range, E2 As Range
Dim ws2 As Worksheet, rng As Range, lastR As Long, r As Long

Sub MasterSub()
    Application.ScreenUpdating = False
    CreateNewLayout
    RejectData
End Sub

Private Sub CreateNewLayout()
    Set wf = Application.WorksheetFunction
'copy to new sheet and sort
    Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
    Set ws2 = Sheets(Sheets.Count)
    With ws2
        lastR = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A2:C" & lastR)
            .Sort Key1:=.Range("C2"), Order1:=xlDescending, Header:=xlNo
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
        End With
    End With
'new layout
    With ws2
        .Range("B3:B" & lastR).Copy .Range("D2")
        .Range("A1").AutoFilter
        .Range("A1:A" & lastR).AutoFilter Field:=3, Criteria1:=False
        .Range("A2:A" & lastR + 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .Range("D1") = "False"
        .Range("B1") = "True"
        .Range("C1").EntireColumn.Delete
    End With
'set column ranges
    With ws2
        Set A2 = .Range("A2").Resize(lastR)
        Set B2 = A2.Offset(, 1)
        Set C2 = A2.Offset(, 2)
        Set D2 = A2.Offset(, 3)
        Set E2 = A2.Offset(, 4)
        D2.Value = B2.Value
        E2.Value = C2.Value
    End With
End Sub

Private Sub RejectData()
    lastR = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
   
'remove all higher value counts where both are high (reduces range of counts)
    For r = 2 To lastR
        SetRowRanges
        If wf.CountIf(D2, mT2) > 50 And wf.CountIf(E2, mF2) > 50 Then
        rng.ClearContents
        End If
    Next r

'remove clear outliers and delete rows not selected (reduces discrepancies between TRUE and FALSE)
    For r = 2 To lastR
        SetRowRanges
        If wf.CountIfs(D2, mT2) > wf.CountIfs(E2, mT2) And wf.CountIfs(E2, mF2) > wf.CountIfs(D2, mF2) Then rng.ClearContents
    Next r
   
    E2.SpecialCells(xlCellTypeBlanks).EntireRow.Delete                  'range always includes at least 1 blank cell avoiding need for On Error Resume Next
    Range(D2, E2).ClearContents
End Sub

Private Sub SetRowRanges()
    With ws2
        Set ID = .Cells(r, 1)
        Set mT = .Cells(r, 2)
        Set mF = .Cells(r, 3)
        Set mT2 = .Cells(r, 4)
        Set mF2 = .Cells(r, 5)
        Set rng = mT2.Resize(, 2)
    End With
End Sub

 

[tirumal]

Delete prior code

In this code
- columns B & C are copied to D & E
- rejected rows are marked by clearing values in D & E
- at end all rows with nothing in column E are removed
- temporary data in D & E then deleted

Test this to see if you can make it yield results closer to what you want
- your problem is a classic "chicken and egg" scenario
- additional rules can be added to remove rows based on different criteria etc

I will post code tomorrow to output result in original format

Option Explicit

Dim wf As WorksheetFunction
Dim ID As Range, mT As Range, mF As Range, mT2 As Range, mF2 As Range
Dim A2 As Range, B2 As Range, C2 As Range, D2 As Range, E2 As Range
Dim ws2 As Worksheet, rng As Range, lastR As Long, r As Long

Sub MasterSub()
    Application.ScreenUpdating = False
    CreateNewLayout
    RejectData
End Sub

Private Sub CreateNewLayout()
    Set wf = Application.WorksheetFunction
'copy to new sheet and sort
    Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
    Set ws2 = Sheets(Sheets.Count)
    With ws2
        lastR = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A2:C" & lastR)
            .Sort Key1:=.Range("C2"), Order1:=xlDescending, Header:=xlNo
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
        End With
    End With
'new layout
    With ws2
        .Range("B3:B" & lastR).Copy .Range("D2")
        .Range("A1").AutoFilter
        .Range("A1:A" & lastR).AutoFilter Field:=3, Criteria1:=False
        .Range("A2:A" & lastR + 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .Range("D1") = "False"
        .Range("B1") = "True"
        .Range("C1").EntireColumn.Delete
    End With
'set column ranges
    With ws2
        Set A2 = .Range("A2").Resize(lastR)
        Set B2 = A2.Offset(, 1)
        Set C2 = A2.Offset(, 2)
        Set D2 = A2.Offset(, 3)
        Set E2 = A2.Offset(, 4)
        D2.Value = B2.Value
        E2.Value = C2.Value
    End With
End Sub

Private Sub RejectData()
    lastR = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
  
'remove all higher value counts where both are high (reduces range of counts)
    For r = 2 To lastR
        SetRowRanges
        If wf.CountIf(D2, mT2) > 50 And wf.CountIf(E2, mF2) > 50 Then
        rng.ClearContents
        End If
    Next r

'remove clear outliers and delete rows not selected (reduces discrepancies between TRUE and FALSE)
    For r = 2 To lastR
        SetRowRanges
        If wf.CountIfs(D2, mT2) > wf.CountIfs(E2, mT2) And wf.CountIfs(E2, mF2) > wf.CountIfs(D2, mF2) Then rng.ClearContents
    Next r
  
    E2.SpecialCells(xlCellTypeBlanks).EntireRow.Delete                  'range always includes at least 1 blank cell avoiding need for On Error Resume Next
    Range(D2, E2).ClearContents
End Sub

Private Sub SetRowRanges()
    With ws2
        Set ID = .Cells(r, 1)
        Set mT = .Cells(r, 2)
        Set mF = .Cells(r, 3)
        Set mT2 = .Cells(r, 4)
        Set mF2 = .Cells(r, 5)
        Set rng = mT2.Resize(, 2)
    End With
End Sub

Yes it's much closer.. Has anything changed regarding allocating to the guys with lowest numbers first. I can see few outliers

Allocation test.xlsm
	F	G	H	I	J	K	L	M
33	abbaksh	60	abbaksh	60		smantral	71	119
34	nikumark	60	nikumark	60		mohaaimr	18	67
35	mohaaimr	18	mohaaimr	49		abhyud	5	34
36	rogelios	5	sammula	25	Original Data ->	rogelios	5	6
37	abhyud	5	abhyud	24		sammula	2	41
38	sammula	2	rogelios	5		kamadana	1
39	kamadana	1	bippakay	1		bippakay		1
Sheet1 (2)

Also, yes for The results are better than previous one. But not as close to >=+10 may be cause of the chicken and egg scenario of the condition :D

Allocation test.xlsm
	F	G	H	I
2	Row Labels	Count of TRUE	Row Labels	Count of FALSE
3	snghoj	95	bjjosh	62
4	biswadm	82	nkakulla	61
5	saithom	78	saithom	60
6	blbi	61	sshaka	60
7	alfrdav	60	siaditi	60
8	nkakulla	60	anukriti	60
Sheet1 (2)

 

[tirumal]

I just cross-verified the data and i guess that is what has happened... The true count that got reduced for those managers with discrepancy before, was removed from the managers with lowest data... Hence that is why all of their "FALSE" data is not allocated

 

[tirumal]

Where i remove those extra True data from outliers, the false for other is obviously getting reduced for other people..

Can the code run this way (which is the best possible scenario) in our case. Since True is going high:

-Allocate managers with lowest data first. Taking all of TRUE and FALSE of their data.
-Allocate 60 and upto +5 (65) for TRUE as maximum
-Allocate 60 upto -5 (55) for FALSE

I've tried deleting TRUE data for these outliers and allocated all of thier data for managers with lowest data. The results are quite satisfying expect few managers have -10. If we could fix thing that way, all is great :

Allocation test.xlsm
	E	F	G
9	mohaaimr	18	52
10	tulap	60	50
11	pnrhul	60	51
12	abbaksh	60	51
13	mamidih	60	52
14	smantral	59	54
15	sattili	60	54
16	mtshah	60	55
17	estrb	60	55
18	sshaka	60	56
19	glenmart	60	56
Removed

Also, no need to convert data into original format after getting allocated. The converted format is the best one, i just checked. It's a great way of putting out my data, THANKS! :D

 

[Yongle]

I looks like the basic code is now workable
(working with 2 lines per JobNo was a nightmare!)

Further amendments to get closer to desired results
- 100% fit is statistically unlikely
- to get as close as possible then the only way to do that would be to run the code multiple times sorting the data differently each time
- adding more rules can improve fit
- the more rules that are added the slower the code runs
- the code will run fastest when additional rules are either incorporated into existing rules or are added as separate rules within the current For Loops
- checking starts in row 2 and decision are made by checking those row first
- the sequence of the data changes the output

I remember (from one of the earlier posts) that sorting the data to put the higher count values FIRST improved the output
- I will add that functionality