Public Function basInterpolateRs()
Dim dbs As DAO.Database
Dim rstDates As DAO.Recordset
Dim rstSeedVals As DAO.Recordset
Dim iDate As Date 'Inital Date for a sequence
Dim eDate As Date 'End date for a sequence
Dim iVal As Single 'Inital value for a sequence
Dim eVal As Single 'End Value for a sequence
Dim sglStep() As Single 'Interval / Step for a sequence
Dim sglSeedVals() As Single 'Values seeded in the rs
Dim dtSeedDates() As Date 'Values seeded in the rs
Dim Idx As Integer
'For Demo purposes, initalize the year _
and seed some random dates with random values. To run for production _
Comment out the following call to basMakeYrDates
Call basMakeYrDates
Set dbs = CurrentDb
'SQL for qry_valDates. Of course change the table Name to suit. The table used _
here is strictly for Demo purposes. In any production process the field names _
also need to be associated with the actual table. Here, the dtDate field is _
Date type, while the valDate is a single.
'strSQL = "SELECT dtDate, valDate " _
& "FROM tblDateSeq " _
& "WHERE (((valDate) <> 0)) Or " _
& "(((dtDate) = DateSerial(Year(Date), 1, 1))) Or " _
& "(((dtDate) = DateSerial(Year(Date), 12, 31))) " _
& "ORDER BY dtDate;"
'This is the ordered list of dates with values. It FORCES the list to _
include the first and last elements of the list (new years day to start _
and New Years Eve to end. Unless these HAPPEN to have values, they _
will generally be 0 as the interval is assumed (here at least to be numeric).
Set rstSeedVals = dbs.OpenRecordset("qry_ValDates", dbOpenDynaset)
rstSeedVals.MoveLast
rstSeedVals.MoveFirst
DoEvents
'Creates a set of local arrays for the dates which have values associated, _
and the values asociated with the dates.
Idx = rstSeedVals.RecordCount
ReDim sglSeedVals(Idx)
ReDim dtSeedDates(Idx)
ReDim sglStep(Idx)
'Get the seed values and their dates from the query
Idx = 0
While rstSeedVals.EOF = False
sglSeedVals(Idx) = rstSeedVals!valDate
dtSeedDates(Idx) = rstSeedVals!dtDate
rstSeedVals.MoveNext
Idx = Idx + 1
Wend
'Calculate step values for the intervals
Idx = 0
While Idx < UBound(sglSeedVals)
iDate = dtSeedDates(Idx)
eDate = dtSeedDates(Idx + 1)
iVal = sglSeedVals(Idx)
eVal = sglSeedVals(Idx + 1)
sglStep(Idx) = (eVal - iVal) / (DateDiff("d", iDate, eDate))
Idx = Idx + 1
Wend
'Show us the step values (not necessary - except to understand)
Idx = 0
While Idx < UBound(sglSeedVals)
Debug.Print Idx, dtSeedDates(Idx), sglSeedVals(Idx), sglStep(Idx)
Idx = Idx + 1
Wend
Set rstDates = dbs.OpenRecordset("tblDateSeq", dbOpenDynaset)
'Using the local arrays, calculate (interpolate) and insert the missing values
Idx = 0
While Idx < UBound(sglSeedVals)
While rstDates!dtDate < dtSeedDates(Idx + 1)
iVal = iVal + sglStep(Idx)
rstDates.Edit
rstDates!valDate = iVal
rstDates.Update
rstDates.MoveNext
Wend
Idx = Idx + 1
Wend
End Function
Public Function basMakeYrDates()
'Just be able to male a list of the dates in a Calendar Year _
and randomly fill about a Dozen with value fields with apparently _
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sglRandVal(12) As Single 'Array of random values to insert, randomly
Dim dtRandVal(12) As Double 'Array of random Dates for the values
Dim dtStart As Date
Dim dtCurr As Date
Dim dtEnd As Date
Dim intRange As Integer
Dim intDays As Integer 'Days in the Year [365 | 366]
Dim Idx As Integer
Dim strCriteria As String
dtCurr = DateSerial(Year(Date), 1, 1) '1/1/this year
dtStart = dtCurr
dtEnd = DateSerial(Year(Date), 12, 31) '12/31/thisYear
intDays = DateDiff("d", dtCurr, dtEnd)
intRange = (dtEnd - dtCurr + 1)
'Get the random values
Randomize
While Idx < UBound(sglRandVal)
sglRandVal(Idx) = Rnd() * intDays
dtRandVal(Idx) = CLng(intRange * Rnd())
Idx = Idx + 1
Wend
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * From tblDateSeq;"
DoCmd.SetWarnings False
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tblDateSeq", dbOpenDynaset)
With rst
While dtCurr <= dtEnd
.AddNew
!dtDate = dtCurr
.Update
dtCurr = DateAdd("d", 1, dtCurr)
Wend
DoEvents
End With
Idx = 0
While Idx <= UBound(sglRandVal)
strCriteria = "[dtDate] = " & Chr(35) & DateAdd("d", dtRandVal(Idx), dtStart) & Chr(35)
rst.FindFirst strCriteria
If (rst.NoMatch = False) Then
rst.Edit
rst!valDate = sglRandVal(Idx)
rst.Update
Else
Stop
End If
Idx = Idx + 1
Wend
End Function
![[thumbsup2]](/data/assets/smilies/thumbsup2.gif "[thumbsup2] [thumbsup2]")
Do have a look at one of the links at the bottom of my post. The links will help you [blue]ask better questions[/blue], get [blue]quick responses[/blue], [blue]better answers[/blue], and insite into [blue]etiquette[/blue] here in the forums. Again . . . Welcome to [blue]Tek-Tips![/blue] 