Mombu the Programming Forum sponsored links

Go Back   Mombu the Programming Forum > Programming > Access VBA Code to select records based on date range
User Name
Password
REGISTER NOW! Mark Forums Read

sponsored links


Reply
 
1 30th April 08:31
meredithjonathan
External User
 
Posts: 1
Default Access VBA Code to select records based on date range


This is not a question, but I thought I would post the following code
to help someone out later.

First, a little background. I had a table of roughly 50,000 records
of employee stock option grants, excercises, etc. Each record has a
grant date. I needed to populate this table with the department the
employee was in at the time of the stock option grant.

I had another table with the effective date of the employee's
transfer/hire into a given department. Thus, John Doe might have five
records in this table - one with his hire date, and four more for each
time he moved to a new department (our company separates employees
from managers into different departments for accounting purposes;
hence, if John Doe was promoted, he "transferred" to a different
department).

The hard part was getting Access to choose the department
intelligently from the departments table. So, if John Doe was hired
on May 1, 2003, transferred to a new department on November 1, 2003,
and was granted an option on June 1, 2003, Access should choose John's
first department. I could not accomplish this with queries and joins.

I've loosely-coupled the following code so it is possible to use the
code as is with few modifications. I would appreciate any comment
from experienced programmers on this (I have no formal training) to
further my education.

Option Compare Database
Option ********

Public Sub PopulateTable(strTableName As String)

'strTableName is the table you want to populate

Dim db As Database
Dim rec As DAO.Recordset
Dim strEMPSSN As String
Dim datGrantDate As Date
Dim intIndex1, intIndex2 As Integer
'Index 1 uniquely identifies employee (SSN)
'Index 2 grabs the date of the event (option grant)
Set db = CurrentDb()
Set rec = db.OpenRecordset(strTableName)
intIndex1 = 1 'Set index here
intIndex2 = 10

'Read option table and store employee SSN and grant date for a called
function
With rec
.MoveLast
.MoveFirst
Do While Not .EOF
strEMPSSN = .Fields(intIndex1)
datGrantDate = .Fields(intIndex2)
.Edit
!DEPT = GetDepts(strEMPSSN, datGrantDate) 'Call
function
.Update
.MoveNext
Loop
.Close
End With
Set db = Nothing
Set rec = Nothing
End Sub

Public Function GetDepts(ByVal strSSN As String, ByVal datDate As
Date) As String

Dim dbs As Database
Dim recs As DAO.Recordset
Dim intIndex9, intIndex8 As Integer
Dim strSQL, strTableTwo, strSSNField, strDateField As String

'This function is called from PopulateTable. It retrieves a dept
number
'from the t_empdept based on the two passed arguments

intIndex9 = 4
intIndex8 = 6
strTableTwo = "t_empdept"
strSSNField = "SSN"
strDateField = "Date"
strSQL = "SELECT * FROM " & strTableTwo & " WHERE ((" & strTableTwo &
"." & _
strSSNField & ") = '" & strSSN & "') ORDER BY " & strTableTwo & "." &
_
strDateField & ";"
Debug.Print strSQL
Set dbs = CurrentDb()
Set recs = dbs.OpenRecordset(strSQL, dbOpenDynaset)

With recs
.MoveLast
.MoveFirst
Do While Not .EOF
'The logic in this block chooses the dept an employee
'was in at the grant date (datDate argument)
Select Case .RecordCount
Case 1
GetDepts = .Fields(intIndex9)
GoTo 10
Case Else
If datDate = .Fields(intIndex8) Then
GetDepts = .Fields(intIndex9)
GoTo 10
Else
If datDate > .Fields(intIndex8) Then
Select Case .AbsolutePosition + 1
Case Is < .RecordCount
.MoveNext
Case Else
GetDepts = .Fields(intIndex9)
GoTo 10
End Select
Else
Select Case .AbsolutePosition
Case Is <> 0
.MovePrevious
GetDepts = .Fields(intIndex9)
GoTo 10
Case Else
GetDepts = .Fields(intIndex9)
GoTo 10
End Select
End If
End If
End Select
Loop
'9:
'GetDepts = "9999999" 'If the employee does not
exist in
10: 'table, use dept 9999999
Set dbs = Nothing
Set recs = Nothing
..Close
End With
End Function
  Reply With Quote


  sponsored links


Reply


Thread Tools
Display Modes




Copyright 2006 SmartyDevil.com - Dies Mies Jeschet Boenedoesef Douvema Enitemaus -
666