VBA code to pick data based on multiple conditions

T

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
 
Sort by date Sort by votes
Yongle said:
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
Click to expand...
-I've tried that and the code is pasting the similar data in new sheet.

Yongle said:
the sequence of the data changes the output
Click to expand...
-It's True! and also 100% fit is not possible.

Yongle said:
I remember (from one of the earlier posts) that sorting the data to put the higher count values FIRST improved the output
Click to expand...

It did, but it's leaving out the ones with lower count. We can eliminate data from large count but small counts (<60) should always be considered as that is their only data.
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Yongle said:
- I will add that functionality
Click to expand...
How about sorting the data with higher count values first (which is getting closer to desired results) AND THEN looking for the smaller numbers and allocating 100% of them. That might create >= 5 more allocations to few managers which is still a great output!
 
Upvote 0
Yes - that is exactly what I was thinking
I have tried to bias it still futher by excluding the lower counts

Again delete the original code
Test and let me know if it helps
10 may not be the optimal value
If countT > 10 And countF > 10 Then ws2.Cells(r, "F").Resize(, 2) = Array(countT, countF)

VBA Code: 
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, F2 As Range, G2 As Range
Dim ws2 As Worksheet, rng As Range, lastR As Long, r As Long
Dim countT As Long, countF 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("C1").EntireColumn.Delete
        .Range("B1") = True
        .Range("C1") = False
        .Range("D1") = True
        .Range("E1") = False
        .Range("F1") = "Count TRUE"
        .Range("G1") = "Count FALSE"
    End With
'set column ranges
    With ws2
        lastR = .Range("A" & .Rows.Count).End(xlUp).Row
        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)
        Set F2 = A2.Offset(, 5)
        Set G2 = A2.Offset(, 6)
        D2.Value = B2.Value
        E2.Value = C2.Value
    End With
'add count values for each manager
        For r = 2 To lastR
            SetRowRanges
            countT = wf.CountIf(B2, mT): countF = wf.CountIf(C2, mF)
            If countT > 10 And countF > 10 Then ws2.Cells(r, "F").Resize(, 2) = Array(countT, countF)
        Next r
'sort based on count
        SortData ("F2")
        SortData ("G2")
End Sub
Private Sub SortData(Key As String)
    With ws2
        lastR = .Range("A" & Rows.Count).End(xlUp).Row
        With .Range("A2:G" & lastR)
            .Sort Key1:=.Range(Key), Order1:=xlAscending, Header:=xlNo
        End With
    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.CountIf(D2, mT2) > wf.CountIf(E2, mT2) And wf.CountIf(E2, mF2) > wf.CountIf(D2, mF2) Then rng.ClearContents
    Next r
    
  '  E2.SpecialCells(xlCellTypeBlanks).EntireRow.Delete                  'range includes blank cell to avoid 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
 
Upvote 0
Yes - that is exactly what I was thinking
I have tried to bias it still futher by excluding the lower counts

Again delete the original code
Test this and let me know if it helps
10 may not be the optimal value
If countT > 10 And countF > 10 Then ws2.Cells(r, "F").Resize(, 2) = Array(countT, countF)

VBA Code: 
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, F2 As Range, G2 As Range
Dim ws2 As Worksheet, rng As Range, lastR As Long, r As Long
Dim countT As Long, countF 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("C1").EntireColumn.Delete
        .Range("B1") = True
        .Range("C1") = False
        .Range("D1") = True
        .Range("E1") = False
        .Range("F1") = "Count TRUE"
        .Range("G1") = "Count FALSE"
    End With
'set column ranges
    With ws2
        lastR = .Range("A" & .Rows.Count).End(xlUp).Row
        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)
        Set F2 = A2.Offset(, 5)
        Set G2 = A2.Offset(, 6)
        D2.Value = B2.Value
        E2.Value = C2.Value
    End With
'add count values for each manager
        For r = 2 To lastR
            SetRowRanges
            countT = wf.CountIf(B2, mT): countF = wf.CountIf(C2, mF)
            If countT > 10 And countF > 10 Then ws2.Cells(r, "F").Resize(, 2) = Array(countT, countF)
        Next r
'sort based on count
        SortData ("F2")
        SortData ("G2")
End Sub
Private Sub SortData(Key As String)
    With ws2
        lastR = .Range("A" & Rows.Count).End(xlUp).Row
        With .Range("A2:G" & lastR)
            .Sort Key1:=.Range(Key), Order1:=xlAscending, Header:=xlNo
        End With
    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.CountIf(D2, mT2) > wf.CountIf(E2, mT2) And wf.CountIf(E2, mF2) > wf.CountIf(D2, mF2) Then rng.ClearContents
    Next r
    
    E2.SpecialCells(xlCellTypeBlanks).EntireRow.Delete                  'range includes blank cell to avoid 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
 
Upvote 0
This is giving "Identifier under curosor" error for this line:

VBA Code: 
lastR = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
 
Upvote 0
Yongle said:
Yes - that is exactly what I was thinking
I have tried to bias it still futher by excluding the lower counts

Again delete the original code
Test this and let me know if it helps
10 may not be the optimal value
If countT > 10 And countF > 10 Then ws2.Cells(r, "F").Resize(, 2) = Array(countT, countF)

VBA Code: 
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, F2 As Range, G2 As Range
Dim ws2 As Worksheet, rng As Range, lastR As Long, r As Long
Dim countT As Long, countF 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("C1").EntireColumn.Delete
        .Range("B1") = True
        .Range("C1") = False
        .Range("D1") = True
        .Range("E1") = False
        .Range("F1") = "Count TRUE"
        .Range("G1") = "Count FALSE"
    End With
'set column ranges
    With ws2
        lastR = .Range("A" & .Rows.Count).End(xlUp).Row
        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)
        Set F2 = A2.Offset(, 5)
        Set G2 = A2.Offset(, 6)
        D2.Value = B2.Value
        E2.Value = C2.Value
    End With
'add count values for each manager
        For r = 2 To lastR
            SetRowRanges
            countT = wf.CountIf(B2, mT): countF = wf.CountIf(C2, mF)
            If countT > 10 And countF > 10 Then ws2.Cells(r, "F").Resize(, 2) = Array(countT, countF)
        Next r
'sort based on count
        SortData ("F2")
        SortData ("G2")
End Sub
Private Sub SortData(Key As String)
    With ws2
        lastR = .Range("A" & Rows.Count).End(xlUp).Row
        With .Range("A2:G" & lastR)
            .Sort Key1:=.Range(Key), Order1:=xlAscending, Header:=xlNo
        End With
    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.CountIf(D2, mT2) > wf.CountIf(E2, mT2) And wf.CountIf(E2, mF2) > wf.CountIf(D2, mF2) Then rng.ClearContents
    Next r
   
    E2.SpecialCells(xlCellTypeBlanks).EntireRow.Delete                  'range includes blank cell to avoid 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
Click to expand...

Tried this,
It's showing the same error on this line:

VBA Code: 
If wf.CountIf(D2, mT2) > 60 And wf.CountIf(E2, mF2) > 60 Then
 
Upvote 0
tirumal said:
This is giving "Identifier under curosor" error for this line:
Click to expand...
The problem is elsewhere
Simply delete the line and test
(the correct value for lastR has already been calculated, and therefore the line is redundant)
 
Upvote 0
Screenshot (114).png
 
Upvote 0
The code works perfectly for me and that ine is unchanged from before so it is a puzzle as to why it fails for you

You need to help me debug it
Replace that bit of the code with code below
What are the values returned by message box for r and lastR ?

VBA Code: 
'remove all higher value counts where both are high (reduces range of counts)

    For r = 2 To lastR
        SetRowRanges
        On Error Resume Next
        If wf.CountIf(D2, mT2) > 50 And wf.CountIf(E2, mF2) > 50 Then
            If Err.Number <> 0 Then
                MsgBox r ,,"r"
                MsgBox lastR,,"lastR"
                Exit Sub
                rng.ClearContents
            End If
        End If
    Next r
 
Upvote 0
r has returned - 2
lastR has returned- 9903

The code returns this result in new worksheet (it printed whole data):

Screenshot (117).png
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA : Audit Selector Based on Task with no repeated user.
Replies
0
Views
197
AmirFirdaus9509
A
F
  • Question Question
Count # of values that fall within a certain date range
Replies
1
Views
576
RobP
R
ChrisMac1
  • Question Question
VBA - Compare specific data in one column on one sheet, with the same column on 4 other sheets, copy specific cells if match found.
Replies
1
Views
438
ChrisMac1
ChrisMac1
J
  • Question Question
VBA or formula to move data in last used column to column A
Replies
5
Views
229
Peter_SSs
Peter_SSs
lojanica
  • Solved
VBA code checks a condition, stops macro if FALSE, etc.
Replies
3
Views
431
Peter_SSs
Peter_SSs

Forum statistics

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

Share this page

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