Results 1 to 1 of 1

Help needed in analysing presence data

Threaded View

  1. #1
    Registered User
    Join Date
    11-11-2011
    Location
    Finland
    MS-Off Ver
    Excel 2007
    Posts
    1

    Help needed in analysing presence data

    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
    Last edited by tapcap; 11-12-2011 at 08:14 AM. Reason: Asked also in another forum

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1