Group by ID and determine consecutive dates 1

[Xscatolare]

So I have researched this forum and the innerwebs trying to find some similar solution that I could outfit to work for my needs. Since I am posting here I have not succeeded in finding the solution so I appreciate your time to help me out.

Here is what I am looking to do via VBA and future one button execution.

Sample Data:
ID Dte
11009 1/9/2017
11009 3/21/2017
119957 2/21/2017
226715 1/15/2017
226715 3/5/2017
226715 3/13/2017
226715 3/14/2017
239416 2/3/2017
239416 2/6/2017
239416 2/7/2017
239416 2/8/2017
239416 2/15/2017
239416 2/16/2017
239416 3/8/2017
239416 3/30/2017
239416 4/3/2017
239416 4/4/2017
239416 4/5/2017
239416 4/6/2017
239416 4/13/2017
273887 3/14/2017
273887 4/11/2017
273887 4/12/2017
394892 2/20/2017

What I am trying to do is read through the records and determine at what point there are 2 consecutive dates per ID. For example when reading the list you will see that ID 226715 has 4 entries and only 2 of them are consecutive. The ultimate goal is to determine just the first 2 consecutive dates. So in example of 239416 there are dates 4/3, 4/4, 4/5, 4/6. Although there are 4 dates consecutively I only care that the first match of 4/3 and 4/4 exist. For example if there was a range of 4/3, 4/4, 4/5, 4/7, 4/8 this would produce 2 instances of the consecutive days since there was a break in sequence with nothing being recorded for 4/6.

Here is the code thus far. I realize that in the ELSE statement I have the record moving twice when the IDs don't match. It works sometimes but not on long runs and then it skips the first instance of the mismatch.

    Dim strSQL As String
    Dim rsA As DAO.Recordset
    Dim rsB As DAO.Recordset
    
    
   
       Set db = CurrentDb
       strSQL = "SELECT tblUnexcused.SalesID, tblUnexcused.Dte, tblUnexcused.CallInLogFullName" _
          & " FROM tblUnexcused" _
          & " ORDER BY tblUnexcused.SalesID, tblUnexcused.Dte;"
          
       Set rsA = CurrentDb.OpenRecordset(strSQL)
       
       If Not rsA.BOF Then
          rsA.MoveLast
          rsA.MoveFirst '@ 1st record
          
          Set rsB = rsA.Clone
          rsB.MoveLast
          rsB.AbsolutePosition = 1 '@ 2nd record
          
          '----------------------------------
          Do Until rsB.EOF
          
            If rsA!salesid = rsB!salesid Then
                
                Duration = DateDiff("D", rsA!dte, rsB!dte)
                
                MsgBox rsA!salesid & ", " & rsA!dte & Chr(13) & rsB!salesid & ", " & rsB!dte & Chr(13) & "Duration in Days = " & Duration
                rsA.MoveNext
                rsB.MoveNext
            Else
                Duration = DateDiff("D", rsA!dte, rsB!dte)
                MsgBox rsA!salesid & ", " & rsA!dte & Chr(13) & rsB!salesid & ", " & rsB!dte & Chr(13) & "Duration in Days = " & Duration, , "In Else b4 move"
                rsA.Move 2
                rsB.Move 2
                MsgBox rsA!salesid & ", " & rsA!dte & Chr(13) & rsB!salesid & ", " & rsB!dte & Chr(13) & "Duration in Days = " & Duration, , "In Else after move"
            End If
           Loop
          
          
            End If
          '----------------------------------
    
       Set rsB = Nothing
       Set rsA = Nothing
       Set db = Nothing

It is crud as I am just playing with the scenarios and wanting to see what is being returned thus the message boxes. I am not sure that cloning is the right answer however I do not have the skills for arrays. I have thought possibly of doing case statements to test each entry per ID but still thinking that through. I confess I am not fluent in coding but understand most things and typically can find what I need and then tweak it to my needs. I appreciate anyone's time and insight on this project.

 

[Andrzejek]

Nice little exercise

(for some reason I could not include the SQL with the code, my SQL is below the code.)

Dim strSQL As String

Dim lngID As Long
Dim dte As Date
Dim R As Integer
Dim intConsDates As Integer

Set db = CurrentDb
[red]
See the SQL below *
[/red]
Set rst = CurrentDb.OpenRecordset(strSQL)

With rst
    [s].Open strSQL, Cn
[/s]    
    If Not .EOF Then
        .MoveLast
        .MoveFirst
        lngID = !ID.Value
        dte = !dte.Value
        .MoveNext
        
        For R = 2 To .RecordCount
            If lngID = !ID.Value And DateDiff("d", dte, !dte.Value) = 1 Then
                If intConsDates <> R - 1 Then
                    Debug.Print lngID & " and dates: " & _
                                dte & " - " & !dte.Value & _
                                " are consecutive."
                End If
                intConsDates = R
            End If
            
            lngID = !ID.Value
            dte = !dte.Value
            .MoveNext
        Next R
    End If
    .Close
End With
Set rst = Nothing

* strSQL = "SELECT ID, Dte FROM tblUnexcused ORDER BY ID, Dte"

Have fun.

---- Andy

There is a great need for a sarcasm font.

 

[Xscatolare]

Thank you Andy! I have been playing with other tactics that were close but no go for sequence beyond 3 sequential days. I was excited to see your reply so thank you for taking a crack at it. I copied it over but i am getting error 438, Object doesn't support this property or method. Its bombing here ->' With rst .Open strSQL, Cn ' I am not sure what the Cn is referencing? Am i missing a reference in the database?

So i rem'd the Open recordset line and it is working as intended. I went in to add a sql insert string to trap the outputs into a table for reporting. All works good and i am using dte as the firstdte however i am not sure how to get the second date (compared one) into a variable to write into the table?

Thank you again!
Anthony.

 

[Andrzejek]

Ooops.
I did my code in VB6 with ADODB (I am not an Access guy, can you tell?), so my code:
[pre]
With rst
.Open strSQL, Cn
[/pre]
would translate to your Access as:
[pre]
Set rst = CurrentDb.OpenRecordset(strSQL)[/pre]

As for your second question - if you post your working code and tell what you want to happen, we can make it work

Have fun.

---- Andy

There is a great need for a sarcasm font.

 

[Xscatolare]

Hey Andy,
Sitting here tinkering I was able to get it figured out! So far everything appears to be spot on. I can't thank you enough for the support. I have spent the last couple days with help from another trying to get past the 3 day scenario string.

For anyone else, here is my complete code that dumps to a table for reporting. I know some items have not been dimmed yet but I am ready to step away and take a break.

Dim strSQL As String
Dim strDsql As String
Dim strWsql As String


Dim lngID As Long
Dim dte As Date
Dim R As Integer
Dim intConsDates As Integer
Set db = CurrentDb

    'SDate = #3/1/2017#
    'EDate = #4/30/2017#
    SDate = Forms!Frm2FerMain!TxtSDate.Value
    EDate = Forms!Frm2FerMain!TxtEDate.Value



strSQL = "SELECT salesID, Dte,tblUnexcused.CallInLogFullName, tblUnexcused.ManagerOrCoach, tblUnexcused.Shift, tblUnexcused.Pay, tblUnexcused.Reason1, tblUnexcused.Reason2, tblUnexcused.Reason3" _
      & " FROM tblUnexcused" _
      & " WHERE tblUnexcused.Dte Between #" & SDate & "# And #" & EDate & "#" _
      & " ORDER BY salesID, Dte"

       'Clean out the tbl2Fer
       strDsql = "DELETE * FROM Tbl2Fer"
       CurrentDb.Execute strDsql

Set rst = CurrentDb.OpenRecordset(strSQL)

With rst
    '.Open strSQL, cn
    
    If Not .EOF Then
        .MoveLast
        .MoveFirst
        lngID = !salesid.Value
        dte = !dte.Value
        .MoveNext
        
        For R = 2 To .RecordCount
            If lngID = !salesid.Value And DateDiff("d", dte, !dte.Value) = 1 Then
                If intConsDates <> R - 1 Then
                    Debug.Print lngID & " and dates: " & _
                                dte & " - " & !dte.Value & _
                                " are consecutive."
                                firstdte = dte
                                seconddte = .Fields("Dte")
                                salesid = lngID
                                MC = .Fields("ManagerOrCoach")
                                Shift = .Fields("Shift")
                                Pay = .Fields("Pay")
                                FullName = .Fields("CallInLogFullName")
                                R1 = .Fields("Reason1")
                                R2 = .Fields("Reason2")
                                R3 = .Fields("Reason3")
                                strWsql = "INSERT INTO Tbl2Fer ( SDte, EDte, CallInLogFullName, ManagerOrCoach, SalesID, Shift, Pay, Reason1, Reason2, Reason3) VALUES (#" & firstdte & "#, #" & seconddte & "#, '" & FullName & "', '" & MC & "','" & salesid & "', '" & Shift & "', '" & Pay & "', '" & R1 & "', '" & R2 & "', '" & R3 & "')"
                                CurrentDb.Execute strWsql
                End If
                intConsDates = R
            End If
            
            lngID = !salesid.Value
            dte = !dte.Value
            .MoveNext
        Next R
    End If
    .Close
End With
Set rst = Nothing
End Sub

Thank you again Andy for being on this forum and offering your skills! So much appreciated!

 

[Andrzejek]

Good job !

"some items have not been dimmed yet" - use [tt]Option Explicit[/tt], VERY important. It saves you a lot of grief in debugging. Trust me.

A few minor 'suggestions':

Dim strSQL As String[green]
'Dim strDsql As String
'Dim strWsql As String[/green]

Dim lngID As Long
Dim dte As Date
Dim R As Integer
Dim intConsDates As Integer
Set db = CurrentDb
[green]
    'SDate = #3/1/2017#
    'EDate = #4/30/2017#[/green]
    SDate = Forms!Frm2FerMain!TxtSDate.Value
    EDate = Forms!Frm2FerMain!TxtEDate.Value
[green]
       'Clean out the tbl2Fer[/green]
       strSQL = "DELETE * FROM Tbl2Fer"
       CurrentDb.Execute strSQL

strSQL = "SELECT * " _
      & " FROM tblUnexcused" _
      & " WHERE Dte Between #" & SDate & "# And #" & EDate & "#" _
      & " ORDER BY salesID, Dte"

Set rst = CurrentDb.OpenRecordset(strSQL)

With rst
    If Not .EOF Then
        .MoveLast
        .MoveFirst
        lngID = !salesid.Value
        dte = !dte.Value
        .MoveNext
        
        For R = 2 To .RecordCount
            If lngID = !salesid.Value And DateDiff("d", dte, !dte.Value) = 1 Then
                If intConsDates <> R - 1 Then[green]
                    'Debug.Print lngID & " and dates: " & _
                    '            dte & " - " & !dte.Value & _
                    '            " are consecutive."[/green]
                    firstdte = dte
                    seconddte = !Dte.Value
                    salesid = lngID
                    MC = !ManagerOrCoach.Value
                    Shift = !Shift.Value
                    Pay = !Pay.Value
                    FullName = !CallInLogFullName.Value
                    R1 = !Reason1.Value
                    R2 = !Reason2.Value
                    R3 = !Reason3.Value

                    strSQL = "INSERT INTO Tbl2Fer ( SDte, EDte, CallInLogFullName, ManagerOrCoach, SalesID, Shift, Pay, Reason1, Reason2, Reason3) VALUES (#" & firstdte & "#, #" & seconddte & "#, '" & FullName & "', '" & MC & "','" & salesid & "', '" & Shift & "', '" & Pay & "', '" & R1 & "', '" & R2 & "', '" & R3 & "')"
                     CurrentDb.Execute strSQL
                End If
                intConsDates = R
            End If
            
            lngID = !salesid.Value
            dte = !dte.Value
            .MoveNext
        Next R
    End If
    .Close
End With
Set rst = Nothing
End Sub

"spent the last couple days " (!) - ask for help. Live is too short

Kudos for not using spaces in your fields' names.
This allows you to use short [tt]rst!MyField.Value[/tt] instead of [tt]rst.Fields("Tis is my field").Value[/tt]

Have fun.

---- Andy

There is a great need for a sarcasm font.

 

[Xscatolare]

Thank you Andy. "Last couple days" were spent trying to get it going while waiting on a response to this post! I learned a lot but still have way more to go! Thanks for the suggestions to clean things up, makes sense especially on the sql strings. I did have the debug.print commented out when I was running it and then did some testing to validate data and forgot to comment out again.