Sub Extract()
Dim sName, dteStart, dteEnd
Dim oSheetUser As Worksheet
Dim iNextRow As Long
Dim rActivity As Range
Dim rHeading As Range
Dim vI As Variant
Dim vJ As Variant
Dim iLastRow As Long
Dim sFormula As String
sName = InputBox("Input user name")
If sName = "" Then
Exit Sub
Else
dteStart = InputBox("Input start date")
If dteStart = "" Or Not IsDate(dteStart) Then
Exit Sub
Else
dteEnd = InputBox("Input end date")
If dteEnd = "" Or Not IsDate(dteStart) Then
Exit Sub
End If
End If
End If
Sheets("Data").Activate
Set rActivity = Range([A2], [A2].End(xlDown))
Set rHeading = Rows(1)
On Error Resume Next
Set oSheetUser = Worksheets(sName)
On Error GoTo 0
If oSheetUser Is Nothing Then
Set oSheetUser = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSheetUser.Name = sName
End If
oSheetUser.Cells.ClearContents
rHeading.Copy oSheetUser.[A1]
iNextRow = 2
For Each vI In rActivity
If vI.Offset(0, 5).Value = sName Then
vI.EntireRow.Copy (oSheetUser.Cells(iNextRow, 1))
iNextRow = iNextRow + 1
End If
Next vI
With oSheetUser
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("A" & iLastRow + 2)
.Value = "Connection time for period " & _
Format(dteStart, "dd mmm yyyy") & " to " & _
Format(dteEnd, "dd mmm yyyy")
sFormula = "=SUMPRODUCT(" & _
"--(B2:B" & iLastRow & ">=--""" & Format(dteStart, "yyyy/mm/dd") & """)," & _
"--(D2:D" & iLastRow & "<=--""" & Format(dteEnd, "yyyy/mm/dd") & """)," & _
"(E2:E" & iLastRow & "-C2:C" & iLastRow & "))"
.Offset(0, 6).Formula = sFormula
.Offset(0, 6).NumberFormat = "[hh]:mm:ss"
.Offset(2, 0).Value = "Connections for period " & _
Format(dteStart, "dd mmm yyyy") & " to " & _
Format(dteEnd, "dd mmm yyyy")
sFormula = "=SUMPRODUCT(" & _
"--(B2:B" & iLastRow & ">=--""" & Format(dteStart, "yyyy/mm/dd") & """)," & _
"--(D2:D" & iLastRow & "<=--""" & Format(dteEnd, "yyyy/mm/dd") & """)," & _
"--((E2:E" & iLastRow & "-C2:C" & iLastRow & ")>=--""00:01:00""))"
.Offset(2, 6).Formula = sFormula
.Offset(2, 6).NumberFormat = "#,##0"
End With
.Activate
End With
End Sub