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
 
This is the upside down version of previous approach which simplifies everything unbelievably
The sheet is copied in full and unwanted values are deleted
It makes the code much simpler and faster
(eg both legs of a job are kept together and VBA does not need to find the 2nd leg each time etc)
You will still get some bigger outliers - it depends on which 2 managers are allocated to a job
But all managers with smaller allocations receive 100%

The higher the two count values, the more jobs remain on the sheet

Test it and see what you think - hopefully I have not missed anything obvious!

Delete the whole of the previous code and replace with this SINGLE procedure
VBA Code:
Option Explicit

Dim wf As WorksheetFunction
Dim ID As Range, Mgr As Range, Opt As Range
Dim A2 As Range, B2 As Range, C2 As Range
Dim ws2 As Worksheet, rng As Range, lastR As Long, r As Long
Dim count1 As Long, count2 As Long

Sub AllocateJobID()
    Application.ScreenUpdating = False
    Set wf = Application.WorksheetFunction
'sort original data by job number first
    With Sheets("Sheet1")
        .Sort.SortFields.Clear
        lastR = .Range("A" & Rows.Count).End(xlUp).Row
        With .Range("A2:C" & lastR)
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
        End With
'add sheet
        .Copy after:=Sheets(Sheets.Count)
    End With
'set ranges in new sheet
    Set ws2 = Sheets(Sheets.Count)
    
    With ws2
        Set A2 = .Range("A:A")
        Set B2 = .Range("B:B")
        Set C2 = .Range("C:C")
    End With
'loop through values
    For r = 2 To lastR Step 2
        With ws2
            Set ID = .Cells(r, 1)
            Set Mgr = .Cells(r, 2)
            Set Opt = .Cells(r, 3)
            Set rng = .Cells(r, 1).Resize(2, 3)
            'ensure both elements of the job satisfy the condition
            If ID = ID.Offset(1) Then
                If wf.CountIfs(B2, Mgr, C2, Opt) > 5 And wf.CountIfs(B2, Mgr.Offset(1), C2, Opt.Offset(1)) > 5 Then rng.ClearContents
            Else
                GoTo Problem
            End If
        End With
    Next r
    On Error Resume Next        'do not remove this line - code fails if special cells finds nothing
    A2.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Exit Sub
Problem: MsgBox "Job " & ID & vbCr & "in row " & r, vbExclamation, "JOB ENTRY MISSING"

End Sub
 
Last edited:
Upvote 0

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
This is the upside down version of previous approach which simplifies everything unbelievably
The sheet is copied in full and unwanted values are deleted
It makes the code much simpler and faster
(eg both legs of a job are kept together and VBA does not need to find the 2nd leg each time etc)
You will still get some bigger outliers - it depends on which 2 managers are allocated to a job
But all managers with smaller allocations receive 100%

The higher the two count values, the more jobs remain on the sheet

Test it and see what you think - hopefully I have not missed anything obvious!

Delete the whole of the previous code and replace with this SINGLE procedure
VBA Code:
Option Explicit

Dim wf As WorksheetFunction
Dim ID As Range, Mgr As Range, Opt As Range
Dim A2 As Range, B2 As Range, C2 As Range
Dim ws2 As Worksheet, rng As Range, lastR As Long, r As Long
Dim count1 As Long, count2 As Long

Sub AllocateJobID()
    Application.ScreenUpdating = False
    Set wf = Application.WorksheetFunction
'sort original data by job number first
    With Sheets("Sheet1")
        .Sort.SortFields.Clear
        lastR = .Range("A" & Rows.Count).End(xlUp).Row
        With .Range("A2:C" & lastR)
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
        End With
'add sheet
        .Copy after:=Sheets(Sheets.Count)
    End With
'set ranges in new sheet
    Set ws2 = Sheets(Sheets.Count)
   
    With ws2
        Set A2 = .Range("A:A")
        Set B2 = .Range("B:B")
        Set C2 = .Range("C:C")
    End With
'loop through values
    For r = 2 To lastR Step 2
        With ws2
            Set ID = .Cells(r, 1)
            Set Mgr = .Cells(r, 2)
            Set Opt = .Cells(r, 3)
            Set rng = .Cells(r, 1).Resize(2, 3)
            'ensure both elements of the job satisfy the condition
            If ID = ID.Offset(1) Then
                If wf.CountIfs(B2, Mgr, C2, Opt) > 5 And wf.CountIfs(B2, Mgr.Offset(1), C2, Opt.Offset(1)) > 5 Then rng.ClearContents
            Else
                GoTo Problem
            End If
        End With
    Next r
    On Error Resume Next        'do not remove this line - code fails if special cells finds nothing
    A2.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Exit Sub
Problem: MsgBox "Job " & ID & vbCr & "in row " & r, vbExclamation, "JOB ENTRY MISSING"

End Sub
Wow! It truly does the job. It has fixed so many things from the previous code. Runs faster as well and True - false distribution is truly equal. Although the code is working at it's best, i can still see few outliers as you already mentioned. These managers have a higher overall job count as well.

Allocation test.xlsm
ABCD
4Row LabelsTRUEFALSEGrand Total
5ayumishr8050130
6kuniarun7450124
7biswadm6450114
8snghoj6452116
9saithom5350103
10mnallan5050100
11skaveesh5050100
12panchada5050100
13bippakay5050100
14tulap5050100
15alfrdav5050100
Pivot 3


The distribution of True is significantly High. By numbers 14-30 (Almost 20-30%). Which then creates unequal distribution for these guys ONLY. Also False is higher for few no. of people:

Allocation test.xlsm
ABCD
4Row LabelsTRUEFALSEGrand Total
5nikumark5064114
6charchv5056106
7abbaksh5052102
Pivot 3


I know this is because of the given managers' data in the raw data, but is there a fix for this so there is a lesser significant number for these outliers? Ex. max upto +5 to 10
 
Upvote 0
I've set the number to 60 (as that is my true allocation number, not 5) and tried it with a different set of data which has similar columns and this is the output -

almost 50% increase in true allocation for one particular manager:

Allocation test.xlsm
ABCD
4Row LabelsTRUEFALSEGrand Total
5snghoj10860168
6biswadm8660146
7saithom7860138
8glenmart7160131
9wajakhan7060130
10blbi6160121
11skaveesh6060120
12sanikh6060120
13tulap6060120
Sheet7
 
Upvote 0
Glad that moved things in the right direction
- it was becoming more and more complicated using the original approach

Without using an optimisation technique, which would involve multiple runs, there is no way to guarantee that you will get the output you need
- but a 2nd trawl through the data with a different test may get it closer

Will look at that tomorrow
 
Upvote 0
I've set the number to 60 (as that is my true allocation number, not 5) and tried it with a different set of data which has similar columns and this is the output -

almost 50% increase in true allocation for one particular manager:

Allocation test.xlsm
ABCD
4Row LabelsTRUEFALSEGrand Total
5snghoj10860168
6biswadm8660146
7saithom7860138
8glenmart7160131
9wajakhan7060130
10blbi6160121
11skaveesh6060120
12sanikh6060120
13tulap6060120
Sheet7

Attaching the data set (macro-free) that returned the aforementioned error. In case if you wanna test on this data, please use 60 as the number (instead of 5).

File Link: Click here
 
Upvote 0
Having considered it further...
- the data layout is unhelpful
- it would be simpler (for may reasons) if data consisted ONE line per JOBNo
- reducing the number of lines will make VBA faster
- alternative layout (see below) allows for various values to be put against each JobNo (by VBA or formula)
- those values could then be used to filter the data for best-fit

Q1Do you have any objections to this approach ?
Q2 Are you able to get your data laid out as in columns A,B,C below ?
(could use VBA to convert if necessary)

Book1
ABCDEF
1Job IDTrueFalseCount of TRUE Manager Count of FALSE Manager Variance
2000064c8e46c47cb9979dcc0268f223dmmmadhrbjjosh330
30025cfb502dc4ff1833ce4ee36855055agangelewajakhan330
400434abee4e84c2f9785d6da6e149211nkakullammmadhr440
500494aee7a0a40e1b7c8ae4c376491c5vnchannkakulla440
6A00434abee4e84c2f9785d6da6e149211nkakullammmadhr440
7A00494aee7a0a40e1b7c8ae4c376491c5vnchannkakulla440
8B000064c8e46c47cb9979dcc0268f223dmmmadhrbjjosh330
9B0025cfb502dc4ff1833ce4ee36855055agangelewajakhan330
10B00434abee4e84c2f9785d6da6e149211nkakullammmadhr440
11B00494aee7a0a40e1b7c8ae4c376491c5vnchannkakulla440
12C000064c8e46c47cb9979dcc0268f223dmmmadhrbjjosh330
13C0025cfb502dc4ff1833ce4ee36855055agangelewajakhan330
14C00434abee4e84c2f9785d6da6e149211nkakullammmadhr440
15C00494aee7a0a40e1b7c8ae4c376491c5vnchannkakulla440
160042544166e14942b4526401ba60dfcfrdnshsiaditi462
17A000064c8e46c47cb9979dcc0268f223dbjjoshyongle242
18A00110102441d4b478512d5e7691249ddbjjoshyongle242
19A001bce89bdba412a9120e6d86346509eyonglesiaditi462
20A0025cfb502dc4ff1833ce4ee36855055yonglesiaditi462
21A0042544166e14942b4526401ba60dfcfrdnshsiaditi462
22B0042544166e14942b4526401ba60dfcfrdnshsiaditi462
23C0042544166e14942b4526401ba60dfcfrdnshsiaditi462
2400110102441d4b478512d5e7691249ddsattilisattili363
250029b3cdad244e6e9489f6cdcb4ccdd7snghojsnghoj743
26A0002cfccbfb2485cb46ca73a465f76f6yonglevnchan413
27A002646548b2e4428aa059dbacbc7dc92yonglemtshah413
28A0029b3cdad244e6e9489f6cdcb4ccdd7snghojsnghoj743
29A004d143185fd4fceb8ef53eb9dca1384saithomsattili363
30B00110102441d4b478512d5e7691249ddsattilisattili363
31B0029b3cdad244e6e9489f6cdcb4ccdd7snghojsnghoj743
32B004d143185fd4fceb8ef53eb9dca1384saithomsattili363
33C00110102441d4b478512d5e7691249ddsattilisattili363
34C0029b3cdad244e6e9489f6cdcb4ccdd7snghojsnghoj743
35C004d143185fd4fceb8ef53eb9dca1384saithomsattili363
36002701827ff64d5a99c03e8794b481d1snghojalfrdav734
37B002701827ff64d5a99c03e8794b481d1snghojalfrdav734
38C002701827ff64d5a99c03e8794b481d1snghojalfrdav734
390029c74095cb4c5f848beb7bf158f630mtshahskaveesh945
40A001df3620e524224b4cd43d6575f8a63mtshahyongle945
41A002701827ff64d5a99c03e8794b481d1mtshahyongle945
42A0029c74095cb4c5f848beb7bf158f630mtshahskaveesh945
43B0029c74095cb4c5f848beb7bf158f630mtshahskaveesh945
44C0029c74095cb4c5f848beb7bf158f630mtshahskaveesh945
450002cfccbfb2485cb46ca73a465f76f6biswadmrdnsh936
46001bce89bdba412a9120e6d86346509emtshahsshaka936
47001df3620e524224b4cd43d6575f8a63biswadmelisaty936
48002646548b2e4428aa059dbacbc7dc92biswadmnikumark936
49B0002cfccbfb2485cb46ca73a465f76f6biswadmrdnsh936
50B001bce89bdba412a9120e6d86346509emtshahsshaka936
51B001df3620e524224b4cd43d6575f8a63biswadmelisaty936
52B002646548b2e4428aa059dbacbc7dc92biswadmnikumark936
53C0002cfccbfb2485cb46ca73a465f76f6biswadmrdnsh936
54C001bce89bdba412a9120e6d86346509emtshahsshaka936
55C001df3620e524224b4cd43d6575f8a63biswadmelisaty936
56C002646548b2e4428aa059dbacbc7dc92biswadmnikumark936
Sheet2
 
Upvote 0
Sorting data that way should not be a problem as long as it satisfies the conditions.
But im not able to figure out how to separate data that way. A VBA would help if we could sort out data that way and while putting these results out in other sheet, re-sort the results/allocation as per the original format.
 
Upvote 0
Before converting to the new format we must make sure that data is 100% valid (otherwise VBA will ruin the data in output sheet)

Are you able to GUARANTEE that your data is 100% correct in these ways
- EVERY JobNo contains EXACTLY 2 lines
- EVERY JobNo contains one TRUE and one FALSE
- EVERY JobNo contains 2 names

Or is it better if VBA checks the data ?
 
Upvote 0
-I can guarantee with the first 2 points is 100% correct.
-Coming to the third, EVERY JobNo contains two names, YES!
-But some of the JobNo's contains same name for both TRUE and FALSE.
 
Upvote 0

Forum statistics

Threads
1,213,483
Messages
6,113,919
Members
448,533
Latest member
thietbibeboiwasaco

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