VBA code to pick data based on multiple conditions

tirumal

Board Regular
Joined
Feb 16, 2020
Messages
50
Office Version
  1. 2016
Platform
  1. Windows
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
 
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
 
Upvote 0

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
When back at my PC I will explain next steps
 
Upvote 0
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 :unsure:
- additional rules can be added to remove rows based on different criteria etc

I will post code tomorrow to output result in original format

VBA Code:
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
 
Last edited:
Upvote 0
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 :unsure:
- additional rules can be added to remove rows based on different criteria etc

I will post code tomorrow to output result in original format

VBA Code:
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
FGHIJKLM
33abbaksh60abbaksh60smantral71119
34nikumark60nikumark60mohaaimr1867
35mohaaimr18mohaaimr49abhyud534
36rogelios5sammula25Original Data ->rogelios56
37abhyud5abhyud24sammula241
38sammula2rogelios5kamadana1
39kamadana1bippakay1bippakay1
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
FGHI
2Row LabelsCount of TRUERow LabelsCount of FALSE
3snghoj95bjjosh62
4biswadm82nkakulla61
5saithom78saithom60
6blbi61sshaka60
7alfrdav60siaditi60
8nkakulla60anukriti60
Sheet1 (2)
 
Upvote 0
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
 
Upvote 0
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
EFG
9mohaaimr1852
10tulap6050
11pnrhul6051
12abbaksh6051
13mamidih6052
14smantral5954
15sattili6054
16mtshah6055
17estrb6055
18sshaka6056
19glenmart6056
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,224,827
Messages
6,181,198
Members
453,022
Latest member
RobertV1609

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top