VBA help for newbie

[DAD]

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.

 

[DAD]

Ah excellent, thank you very much, it works a treat now

 

[BrianJN1]

I found some unexpected time when I arrived home today. Hopefully this is the solution that you desire.

I'm offering a set of notes because I'd like you to compile a set of data that is different to mine, and maybe with more personnel. Then advise me.

I found it easier to code in ‘segments’, ie, build macros for just those parts in my focus and so avoid an awkward and lengthy growing page. In the end I have linked them into one program my calling their specific name in order at the end of the macro named lap().
There is a separate macro, clear(), which I found useful to erase the “Yes/No/NA” as I was testing.
I did add two buttons to my sheet. One I attached to lap() to run the full programming (during this process I did actually use other buttons, now deleted that allowed me to run those "segments" as I needed). That is where the second button attached to clear() was useful.

The image shows at the top an unprocessed table while that below is the result when the macros have been run.

You will be able to copy and paste A1:M11 from the image into a blank worksheet.
That said, you will have to delete row 1 and Column A which leave you with just the unblemished data. You’ll then have to do a bit of work yourself, add cell borders and resize columns. Now, in the lower table I’ve actually overlaid colours which Conditional Formatting generates when these conditions are applied:
Cell value contains ‘NA’ =$H$3:$H$11,$K$3:$K$11 Background Colour is dark gray.
Cell value contains ‘Yes’ =$E$3:$E$11,$H$3:$H$11,$K$3:$K$11 Background Colour is yellow
Cell value contains ‘No’ =$E$3:$E$11,$H$3:$H$11,$K$3:$K$11 Background Colour is red.
as the HTMLMaker does not pick up Conditional formatting.


If you have followed what I have noted above, then when you add and run the macros, the table should look exactly as that shown in my second table. You’ll note that poor Jones has missed out!

Firstly here is all of the code (clear and the various "lap" stages - btw 'lap' was my abbreviation of "overlapping dates" which this project is essentially about).

Sub clear()
Range("E3:E11, H3:H11, K3:K11").ClearContents
End Sub
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
Rows(16 & ":" & 17).ClearContents
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("L" & a).Value
age1 = Range("M" & 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("L" & b).Value
age2 = Range("M" & b).Value


'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
Next
If flag = 1 Then
Range("E" & a).Value = "No"
Else
Range("E" & a).Value = "Yes"
Range("H" & a).Value = "NA"
Range("K" & a).Value = "NA"
End If
Next
lapB
lapC
lapD
lapE
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub lapB()
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 <> "NA" Then

day1 = Range("F" & a).Value
day2 = Range("G" & a).Value
sen1 = Range("L" & a).Value
age1 = Range("M" & a).Value

For b = 3 To lastrow
day3 = Range("C" & b).Value
day4 = Range("D" & b).Value
sen2 = Range("L" & b).Value
age2 = Range("M" & 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"
   'Range("K" & a).Value = "NA"
End If
Next
End If
Next
End Sub

Sub lapC()
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("L" & a).Value
age1 = Range("M" & 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("L" & b).Value
age2 = Range("M" & b).Value


'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
Next

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

Range("K" & a).Value = "NA"
End If
End If
Next
End Sub

Sub lapD()
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 <> "NA" Then

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
day3 = Range("C" & b).Value
day4 = Range("D" & b).Value
sen2 = Range("L" & b).Value
age2 = Range("M" & 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("L" & a).Value
age1 = Range("M" & a).Value

For b = 3 To lastrow
day3 = Range("F" & b).Value
day4 = Range("G" & b).Value
sen2 = Range("L" & b).Value
age2 = Range("M" & 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
End Sub
Sub lapE()
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


'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
Next

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


End If
End If
Next
End Sub

Now those tables:

Excel 2013/2016
	A	B	C	D	E	F	G	H	I	J	K	L	M
1			PR1		App?	PR2		App?	PR3		App?	Sen	Age
2		Name	St	End		St	End		St	End
3		Jones	3-Jan-18	12-Jan-18		6-May-18	14-May-18		4-Apr-18	14-Apr-18		3-Jun-17	35
4		Smith	13-May-18	25-May-18		10-Nov-18	20-Nov-18		7-Jun-18	17-Jun-18		2-Jun-17	30
5		Chan	2-Jan-18	3-Jan-18		5-Dec-18	12-Dec-18		13-Aug-18	23-Aug-18		1-Jun-17	40
6		Wills	12-Jan-18	23-Jan-18		2-Jul-18	18-Jul-18		5-Oct-18	15-Oct-18		4-Jun-17	41
7		Thom	6-Feb-18	13-Feb-18		1-Mar-18	11-Mar-18		4-Jul-18	14-Jul-18		5-Jun-17	42
8		Ford	3-Mar-18	17-Mar-18		3-Apr-18	10-Apr-18		15-Jan-18	25-Jan-18		6-Jun-17	44
9		Simons	8-Mar-18	15-Mar-18		4-Mar-18	14-Mar-18		6-Sep-18	16-Sep-18		7-Jun-17	43
10		Dean	9-Apr-18	16-Apr-18		9-Oct-18	19-Oct-18		2-Feb-18	12-Feb-18		9-Jun-17	45
11		George	15-Apr-18	28-Apr-18		3-May-18	11-May-18		7-May-18	17-May-18		8-Jun-17	46
12
13			PR1		App?	PR2		App?	PR3		App?	Sen	Age
14		Name	St	End		St	End		St	End
15		Jones	3-Jan-18	12-Jan-18	No	6-May-18	14-May-18	No	4-Apr-18	14-Apr-18	No	3-Jun-17	35
16		Smith	13-May-18	25-May-18	Yes	10-Nov-18	20-Nov-18	NA	7-Jun-18	17-Jun-18	NA	2-Jun-17	30
17		Chan	2-Jan-18	3-Jan-18	Yes	5-Dec-18	12-Dec-18	NA	13-Aug-18	23-Aug-18	NA	1-Jun-17	40
18		Wills	12-Jan-18	23-Jan-18	No	2-Jul-18	18-Jul-18	Yes	5-Oct-18	15-Oct-18	NA	4-Jun-17	41
19		Thom	6-Feb-18	13-Feb-18	Yes	1-Mar-18	11-Mar-18	NA	4-Jul-18	14-Jul-18	NA	5-Jun-17	42
20		Ford	3-Mar-18	17-Mar-18	Yes	3-Apr-18	10-Apr-18	NA	15-Jan-18	25-Jan-18	NA	6-Jun-17	44
21		Simons	8-Mar-18	15-Mar-18	No	4-Mar-18	14-Mar-18	No	6-Sep-18	16-Sep-18	Yes	7-Jun-17	43
22		Dean	9-Apr-18	16-Apr-18	No	9-Oct-18	19-Oct-18	Yes	2-Feb-18	12-Feb-18	NA	9-Jun-17	45
23		George	15-Apr-18	28-Apr-18	Yes	3-May-18	11-May-18	NA	7-May-18	17-May-18	NA	8-Jun-17	46
Sheet1

 

[DAD]

Hi Brian,

Thank you so much mate. Absolutely brilliant. I will set to work tonight to test it and see if I can understand how you did it. I will report back tomorrow with any questions or problems I find.

So thankful for your time. muchas gracias

Pete

 

[DAD]

The code does work fantastically well so far, so thank you for that. Maybe I am not understanding it correctly, but so far the code only allocates one leave period? once it is allocated, it ignores the rest? What I am hoping is that, should there be no overlaps, in theory, a person such as Jones can have all three of his proposed leave periods Approved. The priority system is only there to help decide which ones may be declined if there is an overlap. He decides on the most important leave period, but if there is no overlaps, all three may be approved. Again, sorry if I did not explain this well enough.

 

[BrianJN1]

Ok. If I now understand that correctly, someone whom I have allowed under a Priority 1 but disallowed by virtue of a first allocation is still allowed to have their second, and even third choice, granted provided by virtue of criteria.

Fine. My assumption was to accept the first allocation. Ok, then by your criteria, someone can have up to three preferences approved to be selected as required.
On that basis I've gone back through my code and commented out all lines associated with "NA". That merely means adding an " ' " at the start of the line.

On running the code my small table now looks like this (oh, I've overlaid colours because conditional formatting is not detected):

Excel 2013/2016
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1			PR1		App?	PR2		App?	PR3		App?	Sen	Age
2		Name	St	End		St	End		St	End
3		Jones	3-Jan-18	12-Jan-18	No	6-May-18	14-May-18	No	4-Apr-18	14-Apr-18	No	3-Jun-17	35	***
4		Smith	13-May-18	25-May-18	Yes	10-Nov-18	20-Nov-18	Yes	7-Jun-18	17-Jun-18	Yes	2-Jun-17	30
5		Chan	2-Jan-18	3-Jan-18	Yes	5-Dec-18	12-Dec-18	Yes	13-Aug-18	23-Aug-18	Yes	1-Jun-17	40
6		Wills	12-Jan-18	23-Jan-18	No	2-Jul-18	18-Jul-18	Yes	5-Oct-18	15-Oct-18	No	4-Jun-17	41
7		Thom	6-Feb-18	13-Feb-18	Yes	1-Mar-18	11-Mar-18	No	4-Jul-18	14-Jul-18	No	5-Jun-17	42
8		Ford	3-Mar-18	17-Mar-18	Yes	3-Apr-18	10-Apr-18	No	15-Jan-18	25-Jan-18	No	6-Jun-17	44
9		Simons	8-Mar-18	15-Mar-18	No	4-Mar-18	14-Mar-18	No	6-Sep-18	16-Sep-18	Yes	7-Jun-17	43
10		Dean	9-Apr-18	16-Apr-18	No	9-Oct-18	19-Oct-18	Yes	2-Feb-18	12-Feb-18	No	9-Jun-17	45
11		George	15-Apr-18	28-Apr-18	Yes	3-May-18	11-May-18	Yes	7-May-18	17-May-18	No	8-Jun-17	46
Sheet1

Cell Formulas
Range	Formula
N3	=IF(AND(E3="No",H3="No",K3="No"),"***","")

I've added a formula which alerts to situations as "Jones" being deferred three times.
Is this more like we need?

 

[DAD]

Hi Brian,

That is brilliant mate. Thank you again for your time. It is almost perfect now. The only issue I can see, is that for some reason in priority 2 leave dates, if 2 priority 2 leave dates overlap, it looks at seniority, but it allocates it to the most junior person, not the most senior like it does for the priority 1 column and the Priority 3 column. I have tried sorting through the code, but can't find where the mix up is yet.

Pete

 

[DAD]

Hi Brian,

I may have found the code, but thought I would check with you first. In sub Lap() the code says "If sen1 > sen2 Then" but in sub lapC the code says "If sen1 < sen2 Then" and in sub lapE it also says "If sen1 < sen2 Then". Could the "less than" sign be the wrong way around in sub lapC and E?

 

[BrianJN1]

Hi Brian,

I may have found the code, but thought I would check with you first. In sub Lap() the code says "If sen1 > sen2 Then" but in sub lapC the code says "If sen1 < sen2 Then" and in sub lapE it also says "If sen1 < sen2 Then". Could the "less than" sign be the wrong way around in sub lapC and E?

I'll get back to you on that.
I think that you are right as your seniority order goes from oldest to latest which means that sen1 be preferred.

 

[BrianJN1]

I've gone back and did a "desk-check" against your thoughts.
By that I mean that I have actually scanned what my computer was telling me after it gave me its logic.

Yes, you are correct in your surmise. In creating additional "segments" of code I've copy/pasted but seemingly I've done that from an earlier listing, one I did not void!

In this screenshot we have my check of priority to validate what the computer has already determined to the left. Further down is a table as to what dates are available after the computer transaction.

I am wondering, are you in Australia?
As Annual leave is 4 weeks (maybe 5 if on Shift).
Then too, does your plan have the concept of splitting that leave into 2-2, 3-1 week periods, or even allowing that to be split further?
I'm guessing that, if in Australia, you may have RDOs (Rostered Days Off). Do you have to apply this to your business? Should you need to build that into your calculations?
Lastly, at some point in time you will face Long Service Leave (3/6 months?). That is not addressed.

Probably those are hard questions to be addressed by higher levels of administration.

Excel 2013/2016
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1			PR1		App?	PR2		App?	PR3		App?	Sen	Age
2		Name	St	End		St	End		St	End				P1	P2	P3
3		Jones	3-Jan-18	12-Jan-18	No	6-May-18	14-May-18	No	4-Apr-18	14-Apr-18	No	3-Jun-17	35	N	N	N
4		Smith	13-May-18	25-May-18	Yes	10-Nov-18	20-Nov-18	Yes	7-Jun-18	17-Jun-18	Yes	2-Jun-17	30	Y	Y	Y
5		Chan	2-Jan-18	3-Jan-18	Yes	5-Dec-18	12-Dec-18	Yes	13-Aug-18	23-Aug-18	Yes	1-Jun-17	40	Y	Y	Y
6		Wills	12-Jan-18	23-Jan-18	No	2-Jul-18	18-Jul-18	Yes	5-Oct-18	15-Oct-18	No	4-Jun-17	41	N	Y	N
7		Thom	6-Feb-18	13-Feb-18	Yes	1-Mar-18	11-Mar-18	No	4-Jul-18	14-Jul-18	No	5-Jun-17	42	Y	N	N
8		Ford	3-Mar-18	17-Mar-18	Yes	3-Apr-18	10-Apr-18	No	15-Jan-18	25-Jan-18	No	6-Jun-17	44	Y	N	N
9		Simons	8-Mar-18	15-Mar-18	No	4-Mar-18	14-Mar-18	No	6-Sep-18	16-Sep-18	Yes	7-Jun-17	43	N	N	Y
10		Dean	9-Apr-18	16-Apr-18	No	9-Oct-18	19-Oct-18	Yes	2-Feb-18	12-Feb-18	No	9-Jun-17	45	N	Y	N
11		George	15-Apr-18	28-Apr-18	Yes	3-May-18	11-May-18	No	7-May-18	17-May-18	No	8-Jun-17	46	Y	N	N
12
Sheet1

Excel 2013/2016
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF
1	Jan	1			4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20	21	22	23	24	25	26	27	28	29	30	31
2	Feb	1	2	3	4	5									14	15	16	17	18	19	20	21	22	23	24	25	26	27	28
3	Mar																		18	19	20	21	22	23	24	25	26	27	28	29	30	31
4	Apr	1	2									11	12	13	14															29	30
5	May	1	2	3	4	5																					26	27	28	29	30	31
6	Jun	1	2	3	4	5	6												18	19	20	21	22	23	24	25	26	27	28	29	30
7	Jul	1																		19	20	21	22	23	24	25	26	27	28	29	30	31
8	Aug	1	2	3	4	5	6	7	8	9	10	11	12												24	25	26	27	28	29	30	31
9	Sep	1	2	3	4	5												17	18	19	20	21	22	23	24	25	26	27	28	29	30
10	Oct	1	2	3	4	5	6	7	8												20	21	22	23	24	25	26	27	28	29	30	31
11	Nov	1	2	3	4	5	6	7	8	9												21	22	23	24	25	26	27	28	29	30
12	Dec	1	2	3	4									13	14	15	16	17	18	19	20	21	22	23	24	25	26	27	28	29	30	31
Sheet2

Anyway the code for my "calendar" of left dates is also added.

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
End Sub

 

[DAD]

Hi Brian,

Thank you so much again, I will run some detailed testing again tonight and tomorrow.

With regard to your questions, yes I am located in Australia, and we do have RDO's scheduled, but they are based on a roster system, and therefore do not impact the leave system. As for the leave splitting, we are hoping a system like this will negate the need to mandate fixed duration of leave splitting, giving everyone more flexibility. Though that may need to change in the future, we will have to trial it and see. You raise a good point regarding the Long Service Leave, but at this stage we will keep that on a different ledger. My initial reaction is that a good deal of thought needs to be put into that before we can embark on incorporating that into this system. But great ideas, my gut tells me you have been in Management positions over the years!

Thanks again, I'll get back to you after some testing.

Pete