Assumptions:
- in column A, "Create" always appears after the project number,
- if there are two (or more) start dates in the project, the first one is selected,
- if column A is "Done", column B has date and in column D is the date of execution, then date from column D is taken,
- column F displays the duration in a more friendly form.
Sub ProjectsDuration()
Dim rngData As Range
Dim rng As Range
Dim varAddrs As Variant
Dim lCount As Long
Dim i As Long
Dim rngDone As Range
Dim lDays As Long
Dim dtTime As Date
Set rngData = Range("A1").CurrentRegion
'Range of data
With rngData
Set rngData = .Offset(2).Resize(.Rows.Count - 2, 4)
End With
'Number of projects
lCount = Application.Evaluate("=SUMPRODUCT(ISNUMBER(" & rngData.Columns(1).Address & ")*1)")
'Array of project addresses
ReDim varAddrs(1 To lCount)
lCount = 0
Set rng = rngData.Columns(1).Cells(1).Offset(-1)
'Determine the address of each project
For i = 1 To rngData.Rows.Count
If TypeName(rng.Offset(i).Value) = "Double" Then
lCount = lCount + 1
If lCount > 1 Then
varAddrs(lCount - 1) = varAddrs(lCount - 1) & ":" & rng.Offset(i - 1).Address
varAddrs(lCount) = rng.Offset(i).Address
Else
varAddrs(lCount) = rng.Offset(i).Address
End If
End If
Next i
'Address of the last project
varAddrs(lCount) = varAddrs(lCount) & ":" & rng.Offset(i - 1).Address
'Calculate and insert the result for each project
For lCount = 1 To UBound(varAddrs)
'If there is a date in column D (Completion Date/Time)
If TypeName(Range(varAddrs(lCount)).Cells(1).Offset(, 3).Value) = "Date" Then
'Insert the formula in column E
With Range(varAddrs(lCount)).Cells(1).Offset(, 4)
.FormulaR1C1 = "=RC[-1]-R[1]C[-3]"
lDays = Int(.Value)
dtTime = .Value - lDays
'column F
.Offset(, 1).Value = lDays & IIf(lDays <> 1, " days ", " day ") & Format(dtTime, "hh:mm")
End With
Else
'No date in column D.
'Find the cell with "Done" in the project under study
Set rngDone = Range(varAddrs(lCount)).Find("Done")
If Not rngDone Is Nothing Then
'Insert the formula in column E only when "Done" was found
With Range(varAddrs(lCount)).Cells(1).Offset(, 4)
.Formula = "=" & rngDone.Offset(, 1).Address(0, 0) & _
"-" & Range(varAddrs(lCount)).Cells(2).Offset(, 1).Address(0, 0)
lDays = Int(.Value)
dtTime = .Value - lDays
.Offset(, 1).Value = lDays & IIf(lDays <> 1, " days ", " day ") & Format(dtTime, "hh:mm")
End With
End If
End If
Next lCount
MsgBox "Done", vbInformation, "Projects Duration"
End Sub
Artik