Help needed in analysing presence data

[tapcap]

Hi,

I'm trying to analyse room presence data with VBA. Raw data looks like this:
https://skydrive.live.com/?cid=5CDE0...0CD65C2E75!196
(1=presence, 0=No presence)
Now I need to edit data to hour precision (for example 01/02/2011 10 p.m., 01/02/2011 11 p.m, 01/03/2011 0 a.m, 01/03/2011 1 a.m...).

One way is to calculate presence in minutes and collect data to another table, where the weeks of the year (1-52) are in rows and week days and time (0 - 23 = 0 a.m - 11 p.m) are in colums. It looks like this:
https://skydrive.live.com/?cid=5CDE0...0CD65C2E75!202
An other option is to make table, where date and time are in A column and presence in B column
https://skydrive.live.com/?cid=5CDE0...0CD65C2E75!203

I already got one code from my friend that calculates presence in minute precision and collects data to year table. But it has a little bug. It doesn't work correctly and I don't know how to fix it. I think I know where the problem is. If presence (1) lasts to the next week (from sunday to monday), code doesn't change the week and goes back to the same week monday. (Week is from Monday to Sunday.) Code also doesn't understand if presence lasts multiple days.

So could someone help me to fix the code or to make a new one, please? I'm not so good with VBA and my friend isn't available.

Example file can be found here: https://skydrive.live.com/view.aspx?...D65C2E75%21204

And my friend's code:

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: http://www.ozgrid.com/forum/showthread.php?t=159953