VBA help for newbie

D

DAD

Board Regular
Joined
Jan 8, 2010
Messages
54
Hi Guys and Gals,

I have a project I have been working on for quite some time, but unable to find a workable solution. Up until now, I have been trying to find a solution without the use of VBA, as I am a relative newbie to VBA, but doing lots of reading and "trial and error" coding to fix that. Unfortunately the non-VBA solution is too big and too unworkable, so I am now trying it using VBA solution. I was hoping some of you may generously help get me on the right track?

So I work for a small company, and I am trying to make our system of allocation holiday/vacation dates a little more streamlined. To this end, I have come up with an algorithm to allocate the leave, but just now need to be able to code that into excel so employees can see if their desired leave dates will be approved.

If you observe the pic below, I have drastically simplified the final solution so that it may make it easier for you to help me down the right path. You will see that the employees are Smith, Jones and Chang. They can request up to 3 periods of Holidays/vacation per year, and they allocate each of the periods a priority, 1 being the most desired, 3 being the least. If there is no clash with other requested dates, it is approved, and the column titled "Approved" beside the requested period will say YES. If there is a clash of dates (with any of the dates entered in Priority 1-3), then the person that has the higher priority dates entered (1-3) will have their leave approved (YES) and the lower priority will have NO in the Approved? column. Should the dates clash, and the priority be the same, then the person with the higher seniority (that is the earlier date in column L will be approved (YES), the lower seniority with NO. Should The dates clash, the priority the same, the seniority the same, then the final step will be to allocate the leave to the oldest person (column N).

So to summarise:

1. No clash of dates = Approved
2. Clash of dates = Approved to higher Priority
3. Same dates + same Priority = Approved to higher Seniority
4. Same dates + same Priority + same Seniority = Approved to older person.

I realise this is more complicated than most questions asked here, but I would really appreciate your help. While the final solution is a lot more complicated, if I can gain an understanding of how you experts solve a smaller problem like this, I am sure I will be able to figure out the larger solution.

Many thanks for your time.

1596v9.jpg
 
Sort by date Sort by votes
No, not management although I had positions of responsibility in the Public Sector.

I raised those questions with consideration that you said that you wanted to have only one person on leave at a time; I saw potential issues and wondered if you hav=d considered them.
 
Upvote 0

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Hi Brian,

I did some relatively extensive testing today, and I can't fault it. It seems to be perfect. Thank you again for your time and effort. I have also gained a good working knowledge of VBA along the way, and will be adding bits and pieces to this as I go along, hopefully expanding it's functionality.

Very much appreciated.

Pete
 
Upvote 0
I'm pleased that we've gotten a successful application up and running.
I'm also gratified that you learned something from this as well.

There were actually a few instances where I myself advanced my knowledge.
Thank you for the project and your feedback.
 
Upvote 0
Further to a request to extend this 4 choices, I've done that but I am not happy. I need to correct this issue before I can publish that next phase that you desire.
Take a look here:
Chan excludes Jones, which is fine, but for some reason Jones is then excluding Wills!


<colgroup><col style="width:48pt" width="64"> <col style="mso-width-source:userset;mso-width-alt:3364; width:69pt" width="92" span="2"> <col style="mso-width-source:userset;mso-width-alt:1792;width:37pt" width="49"> </colgroup><tbody>
[TD="class: xl67, width: 64"]Jones[/TD]
[TD="class: xl66, width: 92, align: right"]3-Jan-18[/TD]
[TD="class: xl66, width: 92, align: right"]12-Jan-18[/TD]
[TD="class: xl65, width: 49"]No[/TD]

[TD="class: xl67, width: 64"]Smith[/TD]
[TD="class: xl66, width: 92, align: right"]13-May-18[/TD]
[TD="class: xl66, width: 92, align: right"]25-May-18[/TD]
[TD="class: xl65, width: 49"]Yes[/TD]

[TD="class: xl67, width: 64"]Chan[/TD]
[TD="class: xl66, width: 92, align: right"]2-Jan-18[/TD]
[TD="class: xl66, width: 92, align: right"]3-Jan-18[/TD]
[TD="class: xl65, width: 49"]Yes[/TD]

[TD="class: xl67, width: 64"]Wills[/TD]
[TD="class: xl66, width: 92, align: right"]12-Jan-18[/TD]
[TD="class: xl66, width: 92, align: right"]23-Jan-18[/TD]
[TD="class: xl65, width: 49"]No[/TD]

</tbody>
[TABLE="width: 250"]
<colgroup><col><col><col><col></colgroup><tbody>[TR]
[TD="align: right"][/TD]
[/TR]
[TR]

[/TR]
[TR]

[/TR]
</tbody>[/TABLE]
 
Upvote 0
Ah! Solved. The problem was that while I was denying a person Priority dates I should have then denied the existence of that person in further transactions of that priority.
I believe it is all fixed now. Check it thoroughly before you begin to implement.

I haven't added colour to the sheet here but I have applied conditional formatting as before but with a change of formulae:
Cell value contains ‘Yes’ =$E:$E,$H:$H,$K:$K Background Colour is yellow
Cell value contains ‘No’ =$E:$E,$H:$H,$K:$K Background Colour is red.

The macros have also needed to be edited as various range addresses have been changed.
In Comment #39 above I did not explain that I manually constructed that "Calendar" and the macro to remove allocated dates is withing the codes (clean_dates).
Code: 
Sub lap()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim day1, day2, day3, day4 As Long
Dim sen1, sen2, age1, age2 As Long
Dim lastrow, a, b, flag As Long

lastrow = Cells(Rows.Count, "C").End(xlUp).Row
'PRIORITY ONE
For a = 3 To lastrow

flag = 0
day1 = Range("C" & a).Value
day2 = Range("D" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value

For b = 3 To lastrow

If a <> b Then
flag = 0

day3 = Range("C" & b).Value
day4 = Range("D" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value

If Range("E" & b).Value <> "No" Then
'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   
    If sen1 > sen2 Then
        flag = 1
        
        Exit For
        End If
   If sen1 = sen2 Then
           If age1 < age2 Then
             flag = 1
            
                Exit For
            End If
            End If
End If
End If
End If
Next
If flag = 1 Then
Range("E" & a).Value = "No"
Else
Range("E" & a).Value = "Yes"

End If
Next
lapB
lapC
lapD
lapE
lapF
lapG
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub lapB()

'Excludes dates allocated under Priority One
Dim day1, day2, day3, day4 As Long
Dim sen1, sen2, age1, age2 As Long
Dim lastrow, a, b, flag As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For a = 3 To lastrow


day1 = Range("F" & a).Value
day2 = Range("G" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value

For b = 3 To lastrow
day3 = Range("C" & b).Value
day4 = Range("D" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value


'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   Range("H" & a).Value = "No"
 
End If
Next

Next
End Sub

Sub lapC()
'Allocates new dates according to Criteria
Dim day1, day2, day3, day4 As Long
Dim sen1, sen2, age1, age2 As Long
Dim lastrow, a, b, flag As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For a = 3 To lastrow
If Range("H" & a).Value = "" Then
flag = 0
day1 = Range("F" & a).Value
day2 = Range("G" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value


For b = 3 To lastrow

If a <> b Then
flag = 0

day3 = Range("F" & b).Value
day4 = Range("G" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value
If Range("H" & b).Value <> "No" Then

'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   
    If sen1 < sen2 Then
        flag = 1
        
        Exit For
        End If
   If sen1 = sen2 Then
           If age1 < age2 Then
             flag = 1
            
                Exit For
            End If
            End If
End If
End If
End If
Next

If flag = 1 Then
Range("H" & a).Value = "No"
Else
Range("H" & a).Value = "Yes"

End If
End If
Next
End Sub

Sub lapD()
'Excludes dates allocated under Priority One and Priority Two
Dim day1, day2, day3, day4 As Long
Dim sen1, sen2, age1, age2 As Long
Dim lastrow, a, b, flag As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row

For a = 3 To lastrow

day1 = Range("I" & a).Value
day2 = Range("J" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value

For b = 3 To lastrow
day3 = Range("C" & b).Value  ' Priority One Test
day4 = Range("D" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value


'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   Range("K" & a).Value = "No"
   'Range("K" & a).Value = "NA"
End If
Next
'End If
Next
For a = 3 To lastrow
'If Range("K" & a).Value <> "NA" Then

day1 = Range("I" & a).Value
day2 = Range("J" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value

For b = 3 To lastrow
day3 = Range("F" & b).Value ' Priority Two Test
day4 = Range("G" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value

'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   Range("K" & a).Value = "No"
  End If
Next
'End If
Next
End Sub
Sub lapE()
'Allocates new dates according to Criteria
Dim day1, day2, day3, day4 As Long
Dim sen1, sen2, age1, age2 As Long
Dim lastrow, a, b, flag As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For a = 3 To lastrow
If Range("K" & a).Value = "" Then
flag = 0
day1 = Range("I" & a).Value
day2 = Range("J" & a).Value
sen1 = Range("L" & a).Value
age1 = Range("M" & a).Value


For b = 3 To lastrow

If a <> b Then
flag = 0

day3 = Range("I" & b).Value
day4 = Range("J" & b).Value
sen2 = Range("L" & b).Value
age2 = Range("M" & b).Value

If Range("K" & b).Value <> "No" Then
'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   
    If sen1 < sen2 Then
        flag = 1
        
        Exit For
        End If
   If sen1 = sen2 Then
           If age1 < age2 Then
             flag = 1
            
                Exit For
            End If
            End If
End If
End If
End If
Next

If flag = 1 Then
Range("K" & a).Value = "No"
Else
Range("K" & a).Value = "Yes"


End If
End If
Next
End Sub


Sub lapF()
'Excludes dates allocated under Priority One, Priority Two and Priority Three
Dim day1, day2, day3, day4 As Long
Dim sen1, sen2, age1, age2 As Long
Dim lastrow, a, b, flag As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For a = 3 To lastrow


day1 = Range("L" & a).Value
day2 = Range("M" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value

For b = 3 To lastrow
day3 = Range("C" & b).Value  ' Priority One Test
day4 = Range("D" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value


'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   Range("N" & a).Value = "No"
   
   End If
Next

Next
For a = 3 To lastrow

day1 = Range("L" & a).Value
day2 = Range("M" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value

For b = 3 To lastrow
day3 = Range("F" & b).Value ' Priority Two Test
day4 = Range("G" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value

'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   Range("N" & a).Value = "No"
  End If
Next

Next
For a = 3 To lastrow


day1 = Range("L" & a).Value
day2 = Range("M" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value

For b = 3 To lastrow
day3 = Range("I" & b).Value  ' Priority Three Test
day4 = Range("J" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value

'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   Range("N" & a).Value = "No"
  End If
Next

Next
End Sub
Sub lapG()
'Allocates new dates according to Criteria
Dim day1, day2, day3, day4 As Long
Dim sen1, sen2, age1, age2 As Long
Dim lastrow, a, b, flag As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For a = 3 To lastrow
If Range("N" & a).Value = "" Then
flag = 0
day1 = Range("L" & a).Value
day2 = Range("M" & a).Value
sen1 = Range("O" & a).Value
age1 = Range("P" & a).Value


For b = 3 To lastrow

If a <> b Then
flag = 0

day3 = Range("L" & b).Value
day4 = Range("M" & b).Value
sen2 = Range("O" & b).Value
age2 = Range("P" & b).Value

If Range("N" & b).Value <> "No" Then
'Set filter for overlap of dates
  If (day3 >= day1 And day3 <= day2) Or (day1 >= day3 And day1 <= day4) Then
   
    If sen1 < sen2 Then
        flag = 1
        
        Exit For
        End If
   If sen1 = sen2 Then
           If age1 < age2 Then
             flag = 1
            
                Exit For
            End If
            End If
End If
End If
End If
Next

If flag = 1 Then
Range("N" & a).Value = "No"
Else
Range("N" & a).Value = "Yes"


End If
End If
Next
End Sub
Sub clean_dates()
Sheets("Sheet1").Select
Dim a, b, c, d As Long
Dim lastrow As Long
Dim dy1, mt1, dy2, mt2 As Integer
lastrow = Cells(Rows.Count, "C").End(xlUp).Row

For a = 3 To lastrow
Sheets("Sheet1").Select
dy1 = Day(Range("sheet1!c" & a).Value) + 1
mt1 = Month(Range("sheet1!c" & a).Value)
dy2 = Day(Range("sheet1!d" & a).Value) + 1
mt2 = Month(Range("sheet1!d" & a).Value)
    If Range("sheet1!E" & a).Value = "Yes" Then
        Sheets("sheet2").Select
        Range(Cells(mt1, dy1), Cells(mt2, dy2)).ClearContents
    End If
Next

For a = 3 To lastrow
Sheets("Sheet1").Select
dy1 = Day(Range("sheet1!f" & a).Value) + 1
mt1 = Month(Range("sheet1!f" & a).Value)
dy2 = Day(Range("sheet1!g" & a).Value) + 1
mt2 = Month(Range("sheet1!g" & a).Value)
    If Range("sheet1!H" & a).Value = "Yes" Then
        Sheets("sheet2").Select
        Range(Cells(mt1, dy1), Cells(mt2, dy2)).ClearContents
    End If
Next

For a = 3 To lastrow
Sheets("Sheet1").Select
dy1 = Day(Range("sheet1!i" & a).Value) + 1
mt1 = Month(Range("sheet1!i" & a).Value)
dy2 = Day(Range("sheet1!j" & a).Value) + 1
mt2 = Month(Range("sheet1!j" & a).Value)
    If Range("sheet1!K" & a).Value = "Yes" Then
        Sheets("sheet2").Select
        Range(Cells(mt1, dy1), Cells(mt2, dy2)).ClearContents
    End If
Next
For a = 3 To lastrow
Sheets("Sheet1").Select
dy1 = Day(Range("sheet1!L" & a).Value) + 1
mt1 = Month(Range("sheet1!L" & a).Value)
dy2 = Day(Range("sheet1!M" & a).Value) + 1
mt2 = Month(Range("sheet1!M" & a).Value)
    If Range("sheet1!N" & a).Value = "Yes" Then
        Sheets("sheet2").Select
        Range(Cells(mt1, dy1), Cells(mt2, dy2)).ClearContents
    End If
Next
End Sub


Excel 2013/2016
ABCDEFGHIJKLMNOP
1PR1App?PR2App?PR3App?PR4App?SenAge
2NameStEndStEndStEndStEnd
3Jones3-Jan-1812-Jan-18No6-May-1814-May-18No4-Apr-1814-Apr-18No18-Feb-1828-Feb-18Yes3-Jun-1735
4Smith13-May-1825-May-18Yes10-Nov-1820-Nov-18Yes7-Jun-1817-Jun-18Yes17-Jan-1831-Jan-18No2-Jun-1730
5Chan2-Jan-183-Jan-18Yes5-Dec-1812-Dec-18Yes13-Aug-1823-Aug-18Yes20-Jun-1830-Jun-18Yes1-Jun-1740
6Wills12-Jan-1823-Jan-18Yes2-Jul-1818-Jul-18Yes5-Oct-1815-Oct-18No19-Sep-1829-Sep-18Yes4-Jun-1741
7Thom6-Feb-1813-Feb-18Yes1-Mar-1811-Mar-18No4-Jul-1814-Jul-18No27-Dec-186-Jan-19Yes5-Jun-1742
8Ford3-Mar-1817-Mar-18Yes3-Apr-1810-Apr-18No15-Jan-1825-Jan-18No4-Apr-1814-Apr-18No6-Jun-1744
9Simons8-Mar-1815-Mar-18No4-Mar-1814-Mar-18No6-Sep-1816-Sep-18Yes6-Aug-1816-Aug-18No7-Jun-1743
10Dean9-Apr-1816-Apr-18No9-Oct-1819-Oct-18Yes2-Feb-1812-Feb-18No21-Oct-1831-Oct-18Yes9-Jun-1745
11George15-Apr-1828-Apr-18Yes3-May-1811-May-18Yes7-May-1817-May-18No21-Nov-181-Dec-18Yes8-Jun-1746
Sheet1
 
Upvote 0
Hi Brian,

Thank you again so much for your time and effort. There was a small problem with the seniority calculation. The < and > signs were around the wrong way, but I have rectified that and it now seems to work perfectly. I will do some more testing today, but from what I have seen, it is fantastic.

Thank you again.

Pete
 
Upvote 0
The seniority < and > are reversed? Are you sure?
The lower the date in the seniority column is obviously the more senior, ie, came in earlier.
If that is not the issue then please give me an instance.
 
Upvote 0
Hi Brian,

You are correct, the more senior person is the the one with the lower date, in your example above, Smith is more senior to Jones as Smith joined on 2 Jun 17, and Jones joined on 3 Jun 17. In sub Lap() the code says "If sen1 > sen2 Then" but in sub lapC (and the rest) the code says "If sen1 < sen2 Then" I changed the sign around to be the same as in sun Lap() and it now seems to work perfectly.
 
Upvote 0
Nope. There was still a problem. Priority 1, Dean and George overlap!
I only excluded someone who was given a "No" for further transaction, I believe that I should have excluded anyone who was assigned either a positive or negative allocation for any other sorting.


If I apply these edits I have a different problem:
lap()
If Range("E" & b).Value = "" Then

lapC()
If Range("H" & b).Value = "" Then

lapE()
If Range("K" & b).Value = "" Then

lapG()
If Range("N" & b).Value = "" Then

In this case Ford and Simons overlap! :-(
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
VBA - Checking for Duplicates
Replies
2
Views
793
cwhaley1
C
L
  • Question Question
Determine match based on if a date range falls within a larger date range :S
Replies
1
Views
394
dermie_72
D
A
  • Question Question
Auto Update Sheets in Scheduler file
Replies
6
Views
524
anuradhagrewal
A
M
  • Solved
VBA Help - Duplicate & Unwanted Data Removal
Replies
6
Views
879
MoonDancer
M
B
  • Question Question
Formula(s) or VBA to re-distribute PTO hour balance
Replies
1
Views
247
bh24524
B

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

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