Option Explicit
Sub Average()
Dim Original As Range
Dim last As Long
Dim i As Long
Dim j As Long
Dim cell As Range
Dim week As Long
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Original = Columns("A:B")
Worksheets("New").Delete
On Error GoTo 0
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "New"
Original.Copy Range("A1")
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'get precense to column C
Columns("C:C").NumberFormat = "[hh]:mm:ss"
last = Range("B65536").End(xlUp).Row
If Range("B1") = 0 Then
For i = 2 To last Step 2
Range("B" & i).Offset(0, 1) = Range("A" & i + 1) - Range("A" & i)
Next
Else
For i = 1 To last Step 2
Range("B" & i).Offset(0, 1) = Range("A" & i + 1) - Range("A" & i)
Next
End If
'add times to the table
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Collect"
With Worksheets("Collect")
.Activate
.Cells = ""
.Range("B1") = "week:"
.Range("B2") = "time"
.Range("C1").Formula = "1"
AddSeries Range("C1"), 1, 52
AddSeries2 Range("A3")
End With
Worksheets("New").Activate
last = Range("A65536").End(xlUp).Row
For Each cell In Range("A1:A" & last)
week = WeekISO(CDate(cell))
If cell.Offset(0, 1) = 1 Then
cell.Offset(0, 3) = Format(cell + cell.Offset(0, 2), "yyyy-mm-dd hh:mm:ss")
cell.Offset(0, 4) = Format(cell, "hh")
cell.Offset(0, 5) = Format(cell + cell.Offset(0, 2), "hh")
cell.Offset(0, 6) = Minute(cell)
cell.Offset(0, 7) = Minute(cell.Offset(0, 3))
If cell.Offset(0, 5) < cell.Offset(0, 4) Then cell.Offset(0, 5) = cell.Offset(0, 5) + 24
'move data
'same hour
If cell.Offset(0, 4) = cell.Offset(0, 5) Then
Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(Format(cell, "hh") + 1, week + 2).NumberFormat = "General"
Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(Format(cell, "hh") + 1, week + 2) = Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(Format(cell, "hh") + 1, week + 2) + CDbl(Minute(cell.Offset(0, 2)))
'hour difference
Else
If cell.Offset(0, 5) - cell.Offset(0, 4) = 1 Then
Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(Format(cell, "hh") + 1, week + 2) = Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(Format(cell, "hh") + 1, week + 2) + CDbl(60 - Minute(cell))
Worksheets("Collect").Range(UCase(Format(cell.Offset(0, 3), "dddd"))).Cells(Format(cell.Offset(0, 3), "hh") + 1, week + 2) = Worksheets("Collect").Range(UCase(Format(cell.Offset(0, 3), "dddd"))).Cells(Format(cell.Offset(0, 3), "hh") + 1, week + 2) + CDbl(Minute(cell.Offset(0, 3)))
'difference of several hours
Else
For i = cell.Offset(0, 4) To cell.Offset(0, 5)
If i = cell.Offset(0, 4) Then
Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(Format(cell, "hh") + 1, week + 2) = Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(Format(cell, "hh") + 1, week + 2) + CDbl(60 - Minute(cell))
Else
If i = cell.Offset(0, 5) Then
Worksheets("Collect").Range(UCase(Format(cell.Offset(1, 0), "dddd"))).Cells(Format(cell.Offset(1, 0), "hh") + 1, week + 2) = Worksheets("Collect").Range(UCase(Format(cell.Offset(1, 0), "dddd"))).Cells(Format(cell.Offset(1, 0), "hh") + 1, week + 2) + Minute(cell.Offset(1, 0))
' date change
Else
If i > 23 Then
j = i - 24
Worksheets("Collect").Range(UCase(Format(cell.Offset(1, 0), "dddd"))).Cells(j + 1, week + 2) = 60
Else
j = i
Worksheets("Collect").Range(UCase(Format(cell, "dddd"))).Cells(j + 1, week + 2) = 60
End If
End If
End If
Next
End If
End If
End If
Next
Worksheets("Collect").Cells.NumberFormat = "General"
Worksheets("Collect").Cells.EntireColumn.AutoFit
Worksheets("Collect").Activate
End Sub
Sub AddSeries(cell As Range, Beginning As Long, Quantity As Long)
With Worksheets("Collect")
cell.Formula = Beginning
cell.AutoFill Destination:=Range(cell.Address & ":" & cell.Offset(0, Quantity).Address), Type:=xlFillSeries
End With
End Sub
Sub AddSeries2(cell As Range)
Dim i As Long
With Worksheets("Collect")
cell.Select
For i = 1 To 7
ActiveCell = UCase(WeekdayName(i))
ActiveCell.Offset(0, 1).Formula = "0"
ActiveCell.Offset(0, 1).AutoFill Destination:=Range(ActiveCell.Offset(0, 1).Address & ":" & ActiveCell.Offset(23, 1).Address), Type:=xlFillSeries
ActiveWorkbook.Names.Add Name:=ActiveCell, RefersTo:=Range(ActiveCell.Address & ":" & ActiveCell.Offset(23, 54).Address)
ActiveCell.Offset(26, 0).Select
Next
End With
End Sub
Public Function WeekISO(Dates As Date) As Long
Dim D As Date
D = DateSerial(Year(Dates - Weekday(Dates - 1) + 4), 1, 3)
WeekISO = Int((Dates - D + Weekday(D) + 5) / 7)
End Function
Also posted:
Bookmarks