Come see why top tech companies like Mailchimp and Media Temple use Linux Academy to build their employee training programs.
Function EndDate(rgStartTime As Range, rgEndTime As Range, rgLessonDays As Range, rgStartDate As Range, rgHoursTotal As Range, rgHolidays As Range) As Date
Application.Volatile
Dim HoursPerDay As Double, HoursUsed As Double, UseDay As Integer
Dim i As Integer
HoursPerDay = Hour(rgEndTime.Value - rgStartTime.Value)
EndDate = rgStartDate.Value
HoursUsed = 0
Do
UseDay = 0
For i = 1 To rgLessonDays.Columns.Count
If Weekday(EndDate, vbMonday) = i And Len(rgLessonDays.Cells(1, i)) > 0 Then
UseDay = 1
End If
Next i
For i = 1 To rgHolidays.Rows.Count
If EndDate = rgHolidays.Cells(i, 1) Then
UseDay = 0
End If
Next i
If UseDay = 1 Then
HoursUsed = HoursUsed + HoursPerDay
End If
EndDate = EndDate + 1
Loop Until HoursUsed >= rgHoursTotal.Value
EndDate = EndDate - 1
End Function
End-Date-barry2-with-VBA-functio.xlsm
Sub FindEndDate()
Dim WS As Worksheet
Dim WSTrace As Worksheet
Dim MaxRow As Long, MaxRowTrace As Long, I As Long, J As Long, K As Long, L As Long, M As Long
Dim cHolidays As Long
Dim StDate As Date, EndDate As Date
Dim sTime As Variant
Dim vTime As Double, TotTime As Double
Dim TotDays As Long, WorkDays As Long, NextWorkDay As Long, lHolidays As Long, lExtraHolidays As Long
Dim cCell As Range
Dim sWeekdayWorkday As String, sWeekdayStartDay As String
Dim LDays As Integer
Dim bHoliday As Boolean
'---> Disbale Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'---> Set Variables
Set WS = ActiveSheet
Set WSTrace = Sheets("Trace")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
MaxRowTrace = 2
'---> Clean Previous End Date Column
WS.Range("L2:L" & WS.Rows.Count).ClearContents
WSTrace.Range("2:" & WSTrace.Rows.Count).EntireRow.Delete
'---> Start Process
For I = 2 To MaxRow
'---> Update Trace with Start Info
WSTrace.Cells(MaxRowTrace, "A") = WS.Cells(I, "J")
WSTrace.Cells(MaxRowTrace, "B") = WS.Cells(I, "K")
WS.Range("C" & I & ":I" & I).Copy
WSTrace.Range("E" & MaxRowTrace).PasteSpecial xlPasteValues
'---> Determin Hours/Minutes Needed
sTime = Format(WS.Cells(I, "B") - WS.Cells(I, "A"), "hh:mm:ss")
vTime = Hour(sTime) + Minute(sTime) / 60 + Second(sTime) / 3600
TotTime = WS.Cells(I, "K")
RemainTime = TotTime
StDate = WS.Cells(I, "J")
sWeekdayStartDay = Format(WS.Application.WorksheetFunction.Weekday(WS.Range("J" & I), 11), "@")
sWeekdayWorkday = ""
EndDate = StDate
WorkDays = WS.Application.WorksheetFunction.CountA(WS.Range("C" & I & ":" & "I" & I))
'---> Get the Weekdays of the workdays
For J = 3 To 9
If WS.Cells(I, J) <> "" Then
If sWeekdayWorkday <> "" Then sWeekdayWorkday = sWeekdayWorkday & ","
sWeekdayWorkday = sWeekdayWorkday & Format(WS.Cells(I, J).Column - 2, "@")
End If
Next J
'---> First Pass Calculate End Date without Holiday Impact
'---> Get Total Days
'ROUNDUP((K2/(HOUR(B2)-HOUR(A2))/COUNTA(C2:I2))*7-(7-WEEKDAY(J2)),0)
TotDays = Round((TotTime / vTime), 0)
'---> Update Trace
WSTrace.Cells(MaxRowTrace, "C") = vTime
WSTrace.Cells(MaxRowTrace, "D") = TotDays
MaxRowTrace = MaxRowTrace + 1
WSTrace.Cells(MaxRowTrace, Application.WorksheetFunction.Weekday(StDate, 11) + 4) = StDate
MaxRowTrace = MaxRowTrace + 1
lHolidays = 1
lExtraHolidays = 0
bHoliday = False
Do
If bHoliday Then bHoliday = False
For K = lHolidays To TotDays
'---> Determine Start Day is a workday
If K = 1 Then
If InStr(1, sWeekdayWorkday, sWeekdayStartDay, vbBinaryCompare) <> 0 Then
'---> Start Day falls in a workday so count 1 day as of this start day
EndDate = StDate
MaxRowTrace = MaxRowTrace + 1
End If
Else
sWeekdayStartDay = Format(Application.WorksheetFunction.Weekday(EndDate, 11), "@")
End If
'---> Find Next Work Day
L = Val(sWeekdayStartDay)
NextWorkDay = 0
LDays = 0
Do
If L = 7 Then
L = 1
Else
L = L + 1
End If
LDays = LDays + 1
If InStr(1, sWeekdayWorkday, Format(L, "@"), vbBinaryCompare) <> 0 Then
NextWorkDay = L
End If
Loop Until NextWorkDay <> 0
'---> Get the End Date
EndDate = EndDate + LDays
sWeekdayStartDay = Format(NextWorkDay, "@")
'---> Update Trace
WSTrace.Cells(MaxRowTrace, L + 4) = EndDate
'---> Find if EndDate Falls on a Holiday then Increase TotDays by 1
Set cCell = WS.Range("Holidays").Find(what:=EndDate, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not cCell Is Nothing Then
bHoliday = True
lExtraHolidays = lExtraHolidays + 1
WSTrace.Cells(MaxRowTrace, L + 4) = "Holiday"
DoEvents
'---> Update Trace
WSTrace.Cells(MaxRowTrace, "L") = cCell
WSTrace.Cells(MaxRowTrace, "M") = Format(cCell, "Ddd")
End If
'---> Update Trace
MaxRowTrace = MaxRowTrace + 1
Next K
If bHoliday Then
lHolidays = TotDays + 1
TotDays = TotDays + lExtraHolidays
lExtraHolidays = 0
End If
Loop Until bHoliday = False
'---> Affect EndDate to Col L
WS.Cells(I, "L") = EndDate
Next I
'---> Enbale Events
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
'---> Advise User
MsgBox ("End Date updated successfully.")
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Dynamic Chart Range | 13 | 34 | |
Excel fill in a form with pick list or drop downs, also need calendar pick | 25 | 22 | |
VBA - If Bookmark = "XXBOOKMARKXX" then | 15 | 27 | |
How to transform one row line like this in excel table 2010? | 8 | 16 |
Join the community of 500,000 technology professionals and ask your questions.