• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 564
  • Last Modified:

VBA Access Date Range converted to Month listing

Okay, so i probably have the long way at doing this but it works.  If it worked perfectly I would not be requesting a better way.  I need help addressing a performance issue within the code attached.

Here's how it works.
I have three tables:  

Tbl_CertDates:  Monthkey (YYYY_MM), Start_date, End_date - these is to decided what dates follow into a fiscal period.  We use a 5,4,4 month calendar for the year.  so Period 1 January would be from Sunday 1/2/2011 - Saturday 2/5/2011.

Tbl_Ixos_Cert_Review: Sys_Cust_St (system_customer_state/Matchkey), Begindate, expirationdate (Duplicates exist in this table because some record over lap dates.
 
Tbl_Customer_Certs:List  sys_cust_st, and every month for years 2006-2021 listed as YYYY_MM for the title column header ( idea is to have one record per matchkey with combined corresponding YYYY_MM matches)

The Code is suppose to loop though Tbl_Ixos_Cert_Review for each Sys_cust_St (matchkey) and update corresponding months listed within Tbl_Customer_Certs.

 Have add'l code in here because dates are not ways great.  They could have been keyed incorrectly, I don't have access to limit the user.  Some certs have a expire date of 99/99/9999, they don't expire sort of speak.

I also have code checking if a YYYY_MM exist in the tbl_customer_Cert so and skipping so no errors will pop up if not.

I have 121,000+ and growing records.  The code take about 1 sec per record that's 1 1/2 days longs.  Days I don't have to run this once a week.

Any ideas?






Function ReviewCerts()
On Error GoTo Err1_Click

Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim Matchkey As String
Dim i As Integer
Dim Startdate As Date
Dim Enddate As Date
Dim iMonth As Integer
Dim Monthkey As String
Dim Monthstart As String
Dim Monthend As String

    
    Set dbs = CurrentDb

    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE Tbl_Customer_Certs.Sys_Cust_St FROM Tbl_Customer_Certs "
    DoCmd.SetWarnings True

Set rst = dbs.OpenRecordset("Tbl_Ixos_Cert_Review")
rst.MoveFirst
Do Until rst.EOF
Matchkey = rst!Sys_Cust_St
Startdate = rst!Begindate
Enddate = rst!EXPIRATIONDATE
    

    
    If DCount("[Sys_Cust_St]", "Tbl_Customer_Certs", "[Sys_Cust_St]='" & Matchkey & "'") = 0 Then
    DoCmd.SetWarnings False
    DoCmd.RunSQL "INSERT INTO Tbl_Customer_Certs ( Sys_Cust_St ) SELECT '" & Matchkey & "'"
    DoCmd.SetWarnings True
    Else
    End If
    
    Select Case Nz(DCount("[Sys_Cust_St]", "Tbl_Customer_Certs"), 1)
    
    Case Is = 100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 2000
    MsgBox DCount("[Sys_Cust_St]", "Tbl_Customer_Certs")
    
    End Select
    
    Monthstart = Nz(DLookup("[monthkey]", "Tbl_Certdates", "Cdate([Start_Date])<=Cdate('" & Startdate & "') AND Cdate([end_date])>Cdate('" & Startdate & "')"), "error")
    
    If Right(Enddate, 4) = "9999" Then
    Enddate = CDate("12/31/2021")
    End If
    Monthend = Nz(DLookup("[monthkey]", "Tbl_Certdates", "Cdate([Start_Date])<=Cdate('" & Enddate & "') AND Cdate([end_date])>Cdate('" & Enddate & "')"), "error")
    
    'MsgBox Monthstart & "   " & Monthend & "     " & Matchkey
    If Monthstart & Monthend = "errorerror" Then
    'MsgBox "Skip"
    rst.MoveNext

    Else
    'MsgBox "Proceed"
    
    Startdate = Replace(Startdate, "error", CDate("1/1/2005"))
    Enddate = Replace(Enddate, "error", CDate("1/1/2005"))
    
    If Startdate <= #1/1/2006# Then
    Startdate = CDate("1/1/2006")
    End If
    
    'MsgBox Startdate
    
    If Enddate >= #12/31/2021# Then
    Enddate = CDate("12/31/2021")
    End If
    
    'MsgBox Enddate

i = 0
Monthkey = Format(DateAdd("m", i, Startdate), "YYYY_MM")

'MsgBox FieldExists(Monthkey, "Tbl_Customer_Certs")
    
    If FieldExists(Monthkey, "Tbl_Customer_Certs") = True Then

    
    DoCmd.SetWarnings False
    DoCmd.RunSQL "UPDATE Tbl_Customer_Certs SET Tbl_Customer_Certs.[" & Monthkey & "] = -1 " & _
    "WHERE (((Tbl_Customer_Certs.Sys_Cust_St) = '" & Matchkey & "'))"
    DoCmd.SetWarnings True
    Else
    End If
    
iMonth = DateDiff("M", Startdate, Enddate)
    
    If iMonth > 0 Then
        
    Do Until i = iMonth
    i = i + 1
    Monthkey = Format(DateAdd("m", i, Startdate), "YYYY_MM")
    
    If FieldExists(Monthkey, "Tbl_Customer_Certs") = True Then
    DoCmd.SetWarnings False
    DoCmd.RunSQL "UPDATE Tbl_Customer_Certs SET Tbl_Customer_Certs.[" & Monthkey & "] = -1 " & _
    "WHERE (((Tbl_Customer_Certs.Sys_Cust_St) = '" & Matchkey & "'))"
    DoCmd.SetWarnings True
    Else
    End If
    Loop
    
    End If

rst.MoveNext

End If
    Loop
MsgBox "Complete"

rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
    


    
Exit1_Click:
    Exit Function

Er_Click:
        MsgBox Err.Description & vbNewLine & Err.Source & Err.Number
        Resume Exit1_Click
End Function



Function FieldExists(ByVal fieldName As String, ByVal tableName As String) As String

Dim db As Database
    Dim tbl As TableDef
    Dim fld As Field
    Dim strName As String
    Set db = CurrentDb
    Set tbl = db.TableDefs(tableName)
    For Each fld In tbl.Fields
        If fld.Name = fieldName Then
            FieldExists = True
            Exit For
        End If
    Next

     If FieldExists = "True" Then
     FieldExists = "True"
     Else
     FieldExists = "False"
     End If
End Function

Open in new window

0
UWW_Jax
Asked:
UWW_Jax
  • 8
  • 6
  • 2
1 Solution
 
Bill RossCommented:
Hi,

In general you should run a bulk update using an update query.  That said, it is impossible to provide comprensive answer without some sample data.  Please post a sample DB with data and relevant atbles and code and I'll help with the query.

Regards,

Bill
0
 
UWW_JaxAuthor Commented:
0
 
als315Commented:
If you really want table with columns for every month, that seems me strange, at first you sould remove all dcounts and dlookups. Use for Recordset query with sorted columns, like this:
 
SELECT Tbl_Ixos_Cert_Review.Sys_Cust_St, Tbl_Ixos_Cert_Review.BEGINDATE, Tbl_Ixos_Cert_Review.EXPIRATIONDATE
FROM Tbl_Ixos_Cert_Review
ORDER BY Tbl_Ixos_Cert_Review.Sys_Cust_St, Tbl_Ixos_Cert_Review.BEGINDATE, Tbl_Ixos_Cert_Review.EXPIRATIONDATE;

Open in new window

1. Add record for Sys_Cust_St, fill proper values, go to next record.
2. If Sys_Cust_St is same, continue filling. If not - go to 1.
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
UWW_JaxAuthor Commented:
Give me an example.  In this peice of code I want to test if a customer exist in a table, because I don't want to duplicate it.  Then add if it does not exist.

Are you saying I sould use code to search in the table for the record and then Add.  Please provide an alternate example for the code below.
If DCount("[Sys_Cust_St]", "Tbl_Customer_Certs", "[Sys_Cust_St]='" & Matchkey & "'") = 0 Then
    DoCmd.SetWarnings False
    DoCmd.RunSQL "INSERT INTO Tbl_Customer_Certs ( Sys_Cust_St ) SELECT '" & Matchkey & "'"
    DoCmd.SetWarnings True
    Else
    End If

Open in new window

0
 
Bill RossCommented:
Hi,

Just so I understand you want to check off the YYYY_MM column in Tbl_Customer_Certs when the Sys_Cust_St exists in the tbl_Ixos_Cert_Review.  

1.  If the record does not exist in tbl_Ixos_Cert_Review what do you want to do with the tbl_Custf_Certs.
2.  Suppose tbl_Custf_Certs has data already checked that does not match the tbl_Ixos_Cert_Review  dates - do you want that unchecked?

I think we can do this much faster.

Bill
0
 
als315Commented:
1. I think in this case you should add record to tbl_Custf_Certs (may be you should also check dates range before).  Open this table also as recordset and add record with code.
2. Table tbl_Custf_Certs is cleared in the beginning of sub and all Month fields are empty. If you have more then one record for one Sys_Cust_St, you can fill only proper columns.
In your example you have:
Sys_Cust_St      BEGINDATE      EXPIRATIONDATE
MA611459OH      01/27/2011      01/27/2016
MA611459OH      06/02/2011      06/02/2016
If in this case columns from 2011_01 to 2016_02 should be set to true, you can do it without analysis of crosses. In first record you should mark columns from 2001_01 to 2016_01 and in second - from 2011_02 to 2016_02. If your logic is different, you can apply it.
0
 
als315Commented:
Check this sample. May be logic for selecting column will be different for your fiscal periods.
 Star-V3-Tables-Test.accdb
0
 
UWW_JaxAuthor Commented:
This is GREAT I did some testing. I had to modify the code to get it to work.  I only have one issue now.  It's probably something simple.

I had to add "DateRange = DateAdd("D", -1, DateRange)"
It was skipping a month randomly.  This corrected it.

The issue is it's not reviewing the last line / adding it to Tbl_Customer_Certs.

What do we do about that?


Function ReviewCerts()

Dim dbs As DAO.Database
Dim rst, rs As DAO.Recordset
Dim Matchkey As String
Dim i, j, k As Integer
Dim Startdate As Date
Dim Enddate As Date
Dim DateRange As Date
Dim iMonth As Integer
Dim Monthkey As String
Dim Monthstart As String
Dim Monthend As String
Dim strName As String
Set dbs = CurrentDb

    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE Tbl_Customer_Certs.Sys_Cust_St FROM Tbl_Customer_Certs "
    DoCmd.SetWarnings True

Set rst = dbs.OpenRecordset("QSorted")
Set rs = dbs.OpenRecordset("Tbl_Customer_Certs")
rst.MoveFirst
Matchkey = ""
While Not rst.EOF
    If Matchkey <> rst!Sys_Cust_St Then
        If Matchkey <> "" Then rs.Update
        Matchkey = rst!Sys_Cust_St
        rs.AddNew
        rs!Sys_Cust_St = Matchkey

    End If
    Startdate = rst!BEGINDATE
    Enddate = rst!EXPIRATIONDATE
        'MsgBox Matchkey & "   " & Startdate & "    " & Enddate
    If rst!BEGINDATE < DateSerial(2006, 1, 1) Then Startdate = DateSerial(2006, 1, 1)
    If rst!EXPIRATIONDATE > DateSerial(2021, 12, 31) Then Enddate = DateSerial(2021, 12, 31)
        'MsgBox Matchkey & "   " & Startdate & "    " & Enddate
        'i = 0
    For DateRange = Startdate To Enddate
        'i = i + 1
    
        'MsgBox DateRange & "Test1-" & i
        
      Monthkey = Format(DateRange, "YYYY_MM")
      rs.Fields(Monthkey) = True
        
        'MsgBox Monthkey & "Test2-" & i
        
      DateRange = DateAdd("M", 1, DateRange)
      DateRange = DateAdd("D", -1, DateRange)
        'MsgBox DateRange & "Test3-" & i

    Next
    rst.MoveNext
Wend
rs.Close
rst.Close
End Function

Open in new window

0
 
als315Commented:
For last line add:
rs.update before line rs.close
0
 
als315Commented:
DateRange = DateAdd("D", -1, DateRange)
may be not correct - you are subtracting one day with every cycle. Sometimes you can cross month.
May be better to change startdate as:
Startdate = Dateserial(Year(rst!BEGINDATE), Month(rst!BEGINDATE), 1)
0
 
UWW_JaxAuthor Commented:
I had to put that there because the code adds a day and month for each cycle.  After 30 months one month gets skipped.  Sounds crazy but is true. I tested on multiple records.  Thats's I have all of the msg boxes.  (Example 1)

I did change the startdate code just before you posted to
Startdate = Month(rst!BEGINDATE) & "/1/" & Year(rst!BEGINDATE)
Your method of Startdate = DateSerial(Year(rst!BEGINDATE), Month(rst!BEGINDATE), 1) is the same thought.  I found that the last record monthkey was dropping if the day of the start month was greater than the day of the expiry month for records that had mulitples to update. ( Example 2)

I have a few more test to perform to say this is final.  I don't see any change really being needed past this point


Example 1
Sys_Cust_St          EXPIRATIONDATE      BEGINDATE
MA000083OH   9/24/2015                             9/24/2010
MA000083OH   4/1/2012                              4/1/2008

Example 2
Sys_Cust_St         EXPIRATIONDATE      BEGINDATE
MA000503NE         10/11/2013                10/18/2008
0
 
UWW_JaxAuthor Commented:
Code works great!

Final Code to use:


Function ReviewCerts()

Dim dbs As DAO.Database
Dim rst, rs As DAO.Recordset
Dim Matchkey As String
Dim i, j, k As Integer
Dim Startdate As Date
Dim Enddate As Date
Dim DateRange As Date
Dim Monthkey As String
'Dim Monthstart As String
'Dim Monthend As String
'Dim strName As String
Set dbs = CurrentDb


    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE Tbl_Customer_Certs.Sys_Cust_St FROM Tbl_Customer_Certs "
    DoCmd.SetWarnings True

Set rst = dbs.OpenRecordset("QSorted")
Set rs = dbs.OpenRecordset("Tbl_Customer_Certs")
rst.MoveFirst
Matchkey = ""

While Not rst.EOF

    If Matchkey <> rst!Sys_Cust_St Then
        If Matchkey <> "" Then rs.Update
        Matchkey = rst!Sys_Cust_St
        rs.AddNew
        rs!Sys_Cust_St = Matchkey

    End If
    'Startdate = Month(rst!BEGINDATE) & "/1/" & Year(rst!BEGINDATE)
    'Enddate = rst!EXPIRATIONDATE
    Startdate = DateSerial(Year(rst!BEGINDATE), Month(rst!BEGINDATE), 1)
    Enddate = DateSerial(Year(rst!EXPIRATIONDATE), Month(rst!EXPIRATIONDATE), 28)

    If rst!BEGINDATE < DateSerial(2006, 1, 1) Then Startdate = DateSerial(2006, 1, 1)
    If rst!EXPIRATIONDATE > DateSerial(2021, 12, 31) Then Enddate = DateSerial(2021, 12, 31)

    For DateRange = Startdate To Enddate
        
      Monthkey = Format(DateRange, "YYYY_MM")
      rs.Fields(Monthkey) = True
        
      DateRange = DateAdd("M", 1, DateRange)
      DateRange = DateAdd("D", -1, DateRange)

    Next
    rst.MoveNext
    
Wend
rs.Update
rs.Close
rst.Close
MsgBox "Complete"
End Function

Open in new window

0
 
UWW_JaxAuthor Commented:
Code was easy to follow and easy to change.  GREAT JOB!!!!
0
 
UWW_JaxAuthor Commented:
One last question.  Why not open table for record set instead? You used queries.
0
 
als315Commented:
You should sort your table due to some repeated Sys_Cust_St. It is posible with query.
0
 
UWW_JaxAuthor Commented:
thanks.
0

Featured Post

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

  • 8
  • 6
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now