G
Gladiator
All,
I am new to VBA. I have an xl sheet where it has the code that calculates
vacation (R&R) times for employees. The code was written by a person who left
the company a long time ago. But I need to make some modifications to the
code and cannot fiure out how it calculates. I was able to figure out what
'a', 'b', and 'c' are in the code though. Like Remob happens every 366 days
from the contract date, that mean every 366 dyas an employee will get 1.
Regular R&Rs are taken every 90 days, that means 1 every 90 days and Reg RRs
are the R&Rs other than Remob ones. Eligible R&Rs is Reg RR + Remob. I cannot
figure out what "m" and "x" are? Thanks in advance.
Private Sub RR_Calculation_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Response = MsgBox(prompt:="Proceed with running R&R computation?",
Buttons:=vbYesNo)
If Response = vbYes Then
Ext = 0
Else
Exit Sub
End If
For Each e In Range("D143000")
a1 = Cells(e.Row, 23) 'st date
If IsDate(a1) Then
a = DateValue(a1)
Else
a = 0
End If
b1 = Cells(e.Row, 24) 'end date
If IsDate(b1) Then
b = DateValue(b1)
Else
b = 0
End If
c1 = Cells(e.Row, 16) 'contr date
If IsDate(c1) Then
c = DateValue(c1)
Else
c = 0
End If
SAP = Cells(e.Row, 8)
m = 0
rr = 0
remob = 0
x = 0
If Cells(e.Row, 4).Value <> "" Then
If a = 0 Or b = 0 Or a > b Or a = b Or Not IsDate(a) Or Not
IsDate(b) Or a1 <> a Or b1 <> b Then
MsgBox ("Please correct ETC Start and End dates (row " & e.Row &
") and re-run the R&R Calculation!")
Application.Calculation = xlCalculationAutomatic
Exit Sub
ElseIf Right(Cells(e.Row, 4), 2) = "LN" Then
ElseIf c = 0 Or b = c Or Not IsDate(c) Or c1 <> c Then
MsgBox ("Please correct the Contract date (row " & e.Row & ")
and re-run the R&R Calculation!")
Application.Calculation = xlCalculationAutomatic
Exit Sub
Else
Do While c < a 'Contr date < St Date
If m = 2 Then
c = c + 95
m = 0
x = x + 1
Else
c = c + 90
m = m + 1
x = x + 1
End If
Loop
'If Cells(e.Row, 49).Value = 2 Then
If x <> 0 Then
If m = 0 Then
remob = remob + 1
Else
rr = rr + 1
End If
End If
Do While c <= b + 1
If b + 1 - c < 30 And x <> 0 Then
If m = 0 Then
remob = remob - 1
Else
rr = rr - 1
End If
x = x + 1
End If
If m = 2 Then
c = c + 90
remob = remob + 1
m = 0
x = x + 1
Else
c = c + 90
rr = rr + 1
m = m + 1
x = x + 1
End If
Loop
If m = 0 And x <> 0 Then
remob = remob - 1
ElseIf x <> 0 Then
rr = rr - 1
End If
End If
End If
If Cells(e.Row, 11) = 0 Or Cells(e.Row, 11).Value = "" Then
Cells(e.Row, 51).Value = 0 'Eligible R&Rs
Cells(e.Row, 52).Value = 0 'Regular R&R
Cells(e.Row, 53).Value = 0 'Remob R&R
Else
Cells(e.Row, 51).Value = rr + remob
Cells(e.Row, 52).Value = rr
Cells(e.Row, 53).Value = remob
'Eligible R&Rs = rr + remob + rrbc
'Reg R&R = rr
'Remob R&R = remob
End If
Next e
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (" Done!")
End Sub
I am new to VBA. I have an xl sheet where it has the code that calculates
vacation (R&R) times for employees. The code was written by a person who left
the company a long time ago. But I need to make some modifications to the
code and cannot fiure out how it calculates. I was able to figure out what
'a', 'b', and 'c' are in the code though. Like Remob happens every 366 days
from the contract date, that mean every 366 dyas an employee will get 1.
Regular R&Rs are taken every 90 days, that means 1 every 90 days and Reg RRs
are the R&Rs other than Remob ones. Eligible R&Rs is Reg RR + Remob. I cannot
figure out what "m" and "x" are? Thanks in advance.
Private Sub RR_Calculation_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Response = MsgBox(prompt:="Proceed with running R&R computation?",
Buttons:=vbYesNo)
If Response = vbYes Then
Ext = 0
Else
Exit Sub
End If
For Each e In Range("D143000")
a1 = Cells(e.Row, 23) 'st date
If IsDate(a1) Then
a = DateValue(a1)
Else
a = 0
End If
b1 = Cells(e.Row, 24) 'end date
If IsDate(b1) Then
b = DateValue(b1)
Else
b = 0
End If
c1 = Cells(e.Row, 16) 'contr date
If IsDate(c1) Then
c = DateValue(c1)
Else
c = 0
End If
SAP = Cells(e.Row, 8)
m = 0
rr = 0
remob = 0
x = 0
If Cells(e.Row, 4).Value <> "" Then
If a = 0 Or b = 0 Or a > b Or a = b Or Not IsDate(a) Or Not
IsDate(b) Or a1 <> a Or b1 <> b Then
MsgBox ("Please correct ETC Start and End dates (row " & e.Row &
") and re-run the R&R Calculation!")
Application.Calculation = xlCalculationAutomatic
Exit Sub
ElseIf Right(Cells(e.Row, 4), 2) = "LN" Then
ElseIf c = 0 Or b = c Or Not IsDate(c) Or c1 <> c Then
MsgBox ("Please correct the Contract date (row " & e.Row & ")
and re-run the R&R Calculation!")
Application.Calculation = xlCalculationAutomatic
Exit Sub
Else
Do While c < a 'Contr date < St Date
If m = 2 Then
c = c + 95
m = 0
x = x + 1
Else
c = c + 90
m = m + 1
x = x + 1
End If
Loop
'If Cells(e.Row, 49).Value = 2 Then
If x <> 0 Then
If m = 0 Then
remob = remob + 1
Else
rr = rr + 1
End If
End If
Do While c <= b + 1
If b + 1 - c < 30 And x <> 0 Then
If m = 0 Then
remob = remob - 1
Else
rr = rr - 1
End If
x = x + 1
End If
If m = 2 Then
c = c + 90
remob = remob + 1
m = 0
x = x + 1
Else
c = c + 90
rr = rr + 1
m = m + 1
x = x + 1
End If
Loop
If m = 0 And x <> 0 Then
remob = remob - 1
ElseIf x <> 0 Then
rr = rr - 1
End If
End If
End If
If Cells(e.Row, 11) = 0 Or Cells(e.Row, 11).Value = "" Then
Cells(e.Row, 51).Value = 0 'Eligible R&Rs
Cells(e.Row, 52).Value = 0 'Regular R&R
Cells(e.Row, 53).Value = 0 'Remob R&R
Else
Cells(e.Row, 51).Value = rr + remob
Cells(e.Row, 52).Value = rr
Cells(e.Row, 53).Value = remob
'Eligible R&Rs = rr + remob + rrbc
'Reg R&R = rr
'Remob R&R = remob
End If
Next e
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (" Done!")
End Sub