I have been looking for some code that creates a calendar year and will take data from a table and place it in the corresponding date on the calendar. I found some code online (from an older version of access) that pretty much fit the bill, with some modifications it does exactly what I need it to do. Originally, the code pulled data from one table and it was set up to run on the current year. I use two queries, qr_SafetyCal and qr_SafetyCal2, to refine data from the one table. The first query prioritizes the data and eliminates multiple events on any given day. The second query uses the results from the first and specifies the year in the query criteria.
The code works flawlessly as long as I set the year criteria in the qr_SafetyCal2 and specify the first day, ex. 1/1/2017 (datStart) in the underlying code of the calendar year I want displayed.
After getting the code squared away I created a pop up form the user to select the year for the report but when I run the report I get the following error, Runtime Error 3061 too few parameters expected 1.
From what I have been able to research, I believe I changed the dynamic of the code when I referenced the form in the query criteria that the DAO Recordset Used.
As I understand it, the criteria in the query is not passed to the rs and therefore needs to be declared in the code. What I can't figure out is how to declare the variables in the code through reference to the form. I hope that makes some sense to somebody, long explanation but hard to describe something you don't understand.
Below is all the code and you will see some things I've rem'd out that I have tried but did not work. Any help would be greatly appreciated. I apologize ahead of time if the code is not formatted correctly.
Option Compare Database
Option Explicit
Private m_strCTLLabel As String
Private m_strCTLLabelHeader As String
Private colCalendarDates As Collection
Function getCalendarData() As Boolean
Dim rs As DAO.Recordset
Dim strDate As String
Dim strCode As String
Dim i As Integer
'Dim qdf As DAO.QueryDef
'Set qdf = CurrentDb.QueryDef("qr_SafetyCal2")
'qdf.Parameters("[Forms]![fr_SafetyCal]![cboYear]") = [Forms]![fr_SafetyCal]![cboYear]
'Set rs = qdf.OpenRecordset("qr_SafetyCal2", dbOpenDynaset)
Set rs = CurrentDb.OpenRecordset("qr_SafetyCal2", dbOpenDynaset)
Set colCalendarDates = New Collection
With rs
If (Not .BOF) Or (Not .EOF) Then
.MoveLast
.MoveFirst
End If
If .RecordCount > 0 Then
For i = 1 To .RecordCount
strDate = .Fields("Date")
strCode = .Fields("ShortName")
colCalendarDates.Add strCode, strDate
.MoveNext
Next i
End If
.Close
End With
'Return of dates and data collection form qr_SafetyCal2
Set rs = Nothing
End Function
Public Sub loadReportYearCalendar(theReport As Report)
Dim i As Integer
Dim datStart As Date
Dim rptControl As Report
m_strCTLLabel = "labelCELL"
m_strCTLLabelHeader = "labelDAY"
'Load calendar data for the specified year into the collection
Call getCalendarData
With theReport
'Get the first month of the specified year
datStart = "1/1/2017" '"1/1/" & Year(Date), "1/1/" & Forms!
[fr_SafetyCal]![cboYear], Forms![fr_SafetyCal]![txtCalYear]
'Add the specified year to the report's label
.Controls("labelCalendarHeaderLine2").Caption = Year(datStart) & "
iCalendar"
For i = 1 To 12
'Set pointer to subreport control hosting the mini-calendar
Set rptControl = .Controls("childCalendarMonth" & i).Report
'Run procedure to populate control with it's respective year
Call loadReportCalendar(rptControl, datStart)
'Reset and obtain first day of the following month
datStart = DateAdd("m", 1, datStart)
Next i
End With
'Clean up
Set colCalendarDates = Nothing
Set rptControl = Nothing
End Sub
Public Sub loadReportCalendar(theReport As Report, Optional StartDate As
Date, Optional theHeaderColor As Variant)
Dim i As Integer
Dim intCalDay As Integer
Dim datStartDate As Date
Dim intWeekDay As Integer
datStartDate = StartDate
intWeekDay = Weekday(datStartDate)
With theReport
.Controls("labelMONTH").Caption = Format(StartDate, "mmmm")
'Change the day label's backcolor if necessary
If Not (IsMissing(theHeaderColor)) Then
For i = 1 To 7
.Controls("labelDayHeader" & i).BackColor = theHeaderColor
Next
End If
For i = 1 To 42
With .Controls(m_strCTLLabel & i)
If (i >= intWeekDay) And (Month(StartDate) =
Month(datStartDate)) Then
If (datStartDate = Date) Then
.BackColor = 14277081
End If
On Error Resume Next
Dim strCaption As String
Dim strKey As String
strKey = datStartDate
strCaption = ""
strCaption = colCalendarDates.Item(strKey)
colCalendarDates.Remove strKey
'Set back color to grean on days in the past that have
no corresponding event
If (datStartDate < Date) And (strCaption = vbNullString) Then
.Caption = Day(datStartDate)
.Bold = False
.BackColor = vbGreen
.ForeColor = vbWhite
.Heavy = True
'Do not set a back color for days in the future
ElseIf (datStartDate > Date) And (strCaption = vbNullString) Then
.Caption = Day(datStartDate)
.Bold = False
'Set the corresponding labels and formats for each specified event
Else
.Caption = strCaption
.Bold = True
Select Case strCaption
Case "FA"
.BackColor = vbYellow
.ForeColor = 0
.LeftMargin = 0
.TextAlign = 2
Case "FAM"
.BackColor = vbYellow
.ForeColor = 0
.LeftMargin = 0
.TextAlign = 2
.Heavy = True
Case "LTA"
.BackColor = vbRed
.ForeColor = vbWhite
.LeftMargin = 0
.TextAlign = 2
Case "MED"
.BackColor = vbRed
.ForeColor = vbWhite
.LeftMargin = 0
.TextAlign = 2
End Select
End If
datStartDate = DateAdd("d", 1, datStartDate)
Else
.Caption = ""
End If
End With
Next i
End With
End Sub
Here is SQL for the two queries, the first is qr_SafetyCal and the second is qr_SafetyCal2:
SELECT tb_CaseLog.Date, Max(tb_Treatment.Priority) AS MaxOfPriority,
Count(tb_Treatment.TreatmentID) AS CountOfTreatmentID
FROM tb_Treatment INNER JOIN tb_CaseLog ON tb_Treatment.TreatmentID =
tb_CaseLog.Treatment
GROUP BY tb_CaseLog.Date;
SELECT qr_SafetyCal.Date, tb_Treatment.ShortName,
qr_SafetyCal.CountOfTreatmentID AS [Count], Year([Date]) AS CalYear
FROM qr_SafetyCal INNER JOIN tb_Treatment ON qr_SafetyCal.MaxOfPriority =
tb_Treatment.Priority;
No need to reference QueryDef.
Open the recordset object with filtered dataset by referencing the combobox like:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qr_SafetyCal2 WHERE CalYear=" & [Forms]![fr_SafetyCal]![cboYear], dbOpenDynaset)
or if the code is behind the form:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qr_SafetyCal2 WHERE CalYear=" & Me.[cboYear], dbOpenDynaset)
Both examples assume the field is a number type.
If there is no field in query with the year value, it can be extracted from date value field in the VBA construct:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qr_SafetyCal2 WHERE Year([YourFieldnameHere])=" & [Forms]![fr_SafetyCal]![cboYear], dbOpenDynaset)
Code for setting datStart variable:
'Get the first month of the specified year
datStart = "1/1/" & Forms![fr_SafetyCal].[cboYear]
Related
I am trying to delete duplicate records in MS ACCESS.
I have created a query that is sorted on field name.
I have VBA code that runs through the query, and then when finds a match it deletes the record - however it is not picking up the match.
My code looks as follows:
Dim db As DAO.Database
Dim recIn As DAO.Recordset
Dim strFieldName1 As Variant
Dim strFieldDescr2 As Variant
Dim strDomainCat3 As Variant
Dim strBusinessTerm4 As Variant
Dim strtableName5 As Variant
Dim lngRecordsDeleted As Variant
lngRecordsDeleted = 0
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryMyRecords")
If recIn.EOF Then
MsgBox ("No Input Records")
recIn.Close
Set recIn = Nothing
Set db = Nothing
Exit Sub
End If
Do
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Else
strFieldName1 = recIn!FieldName
strFieldDescr2 = recIn!FieldDescr
strDomainCat3 = recIn!DomainCatID
strBusinessTerm4 = recIn!BusinessTermID
strtableName5 = recIn!TableID
End If
recIn.MoveNext
Loop Until recIn.EOF
recIn.Close
Set recIn = Nothing
Set db = Nothing
MsgBox ("You Deleted " & lngRecordsDeleted & " Records")
End Sub
My StrFieldname1, through to to StrTablename5 does populate (after the else statement)
However when I do the compare a second time
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Even though the values are the same, it moves to the else statement, and never does the record delete.
Now I suspect that this could be because I declared my variables as VARIANT type, but if I use any other type, the code falls over every time it reaches a NULL value in the query, and there are cases where any of the fields from the query can and will be null.
Any suggestions would be greatly appreciated
To expand on what Justin said, use the Nz function in your main If statement, like so:
If Nz(recIn!FieldName, "") = strFieldName1 And _
...
Else
strFieldName1 = Nz(recIn!FieldName, "")
...
I've been asked to make a change to a VB6 project. The issue I'm having is that I'm trying to get some data from an Access database and assign the data to some variables.
I've got the code:
Dta_Period.DatabaseName = DB_Accounts_Name$
Dta_Period.RecordSet = "SELECT * FROM [Period]"
Dta_Period.Refresh
The table Period contains 2 fields. sMonth and Period
The sMonth field contains the months January - December. The Period field stores a number 0 to 11, to represent what number has been assigned to which month in the customers financial year. January may be 0, or may be 11, essentially.
I need to know which month goes with which period, which is why I have selected this data from the database. However, I'm stuck with what to do next.
How can I loop over the RecordSet (If this is even possible?) and find out what number has been assigned to each month?
I don't think there is a way I can use a Do Until loop. Is it easier to just use 12 separate queries, and then create an array of strings and an array of integers and then loop over the array of strings until I find the correct month, the use the same index for the array on integers?
EDIT 1
To make things simpler to follow for both myself and anyone attempting to provide an answer, I have modified the code.
Dim rstPeriod As DAO.RecordSet
Dim accDB As DAO.Database
' DB_Session is a Workspace, whilst DB_Accounts_Name$ is the name of the DB I am using
Set accDB = DB_Session.OpenDatabase(DB_Accounts_Name$)
SQL = "SELECT * FROM [Period] ORDER BY [Period]"
Set rstPeriod = accDB.OpenRecordset(SQL, dbOpenDynaset)
If rstPeriod.BOF = False Then
rstPeriod.MoveFirst
End If
Dim strMonth(11) As String
Dim pNumber(11) As Integer
Pseudocode idea:
Do Until rstPeriod.EOF
Select Case currentRow.Field("Month")
Case "January"
strMonth(0) = "January"
pNumber(0) = currentRow.Field("Number")
Case "February"
strMonth(1) = "February"
pNumber(1) = currentRow.Field("Number")
End Select
Loop
Loop through recordset and fill the arrays with the month name and month number.
This assumes the recordset returns no more than 12 records.
Public Sub LoopThroughtRecordset()
On Error GoTo ErrorTrap
Dim rs As DAO.Recordset
Set rs = CurrentDb().OpenRecordset("SELECT * FROM [Period] ORDER BY [Period]", dbOpenSnapShot)
With rs
If .EOF Then GoTo Leave
.MoveLast
.MoveFirst
End With
Dim strMonth(11) As String
Dim pNumber(11) As Integer
Dim idx As Long
For idx = 0 To rs.RecordCount -1
strMonth(idx) = rs![Month]
pNumber(idx) = rs![Number]
rs.MoveNext
Next idx
Leave:
On Error Resume Next
rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Sub
ErrorTrap:
MsgBox Err.Description, vbCritical, CurrentDb.Properties("AppTitle")
Resume Leave
End Sub
'strMonth(0) = January
'strMonth(1) = February
'...
'pNumber(0) = 1
'pNumber(1) = 2
'...
I have the following code in Access VBA.
Public Sub CalculateVol()
Dim vol As Double
Dim rs As Recordset
Dim rs2 As Recordset
Dim iRow As Long, iField As Long
Dim strSQL As String
Dim CurveID As Long
Dim MarkRunID As Long
Dim MaxOfMarkAsofDate As Date
Dim userdate As String
DoCmd.RunSQL "DELETE * FROM HolderTable"
'Clears out the old array from the holder table.
Dim I As Integer
Dim x As Date
userdate = InputBox("Please Enter the Date (mm/dd/yyyy)")
x = userdate
Dim BucketTermAmt As Long
BucketTermAmt = InputBox("Please Enter the Term Amount")
For I = 0 To 76
MaxOfMarkAsofDate = x - I
strSQL = "SELECT * FROM VolatilityOutput WHERE CurveID=" & Forms!Volatility.cboCurve.Value & " AND MaxOfMarkAsofDate=#" & MaxOfMarkAsofDate & "# ORDER BY MaxOfMarkasOfDate, MaturityDate"
Set rs = CurrentDb.OpenRecordset(strSQL, Type:=dbOpenDynaset, Options:=dbSeeChanges)
Set rs2 = CurrentDb.OpenRecordset("HolderTable")
If rs.RecordCount <> 0 Then
rs.MoveFirst
rs.MoveLast
Dim BucketTermUnit As String
Dim BucketDate As Date
Dim MarkAsOfDate As Date
Dim InterpRate As Double
Dim b As String
b = BucketTermAmt
BucketTermUnit = Forms!Volatility.cboDate.Value
BucketDate = DateAdd(BucketTermUnit, b, MaxOfMarkAsofDate)
InterpRate = CurveInterpolateRecordset(rs, BucketDate)
rs2.AddNew
rs2("BucketDate") = BucketDate
rs2("InterpRate") = InterpRate
rs2.Update
End If
Next I
vol = EWMA(0.94)
Forms!Volatility!txtVol = vol
Debug.Print vol
End Sub
The basic idea is that the user inputs a date for MaxofMarkAsofDate. The code then finds that instance of MarkAsofDate in the table VolatilityOutput, and uses it as a reference point to calculate InterpRate. It stores this number in the HolderTable. Then it loops the same procedure, except using one day previous to the user-inputted MarkAsofDate, and then one day previous to that, and so on for a total of 76 times.
The first part works fine but the loop is giving me trouble. If it doesn't find the user-inputted date in the table, it'll just skip it, but still count it as a loop. So while I want 76 data points, I might only end up with 56, for example, if it skips 20 dates. So I want to either stop it from skipping, or just keep looping until HolderTable has a total of 76 numbers in it. How do I do this?
Sounds like you want a while loop since the for loop as written will always go the same number of times. Looks like you might need a second counter to increment your date.
while count < 76
'get rs here
if rs.RecordCount <> 0 Then
'do everything else
count = count + 1
end if
dateCounter = dateCounter + 1
loop
I've created a public function in Access. My goal is if the next business day is a holiday I'm calculating one extra day of interest for payoff purposes. Below is the working code I have. The issue I'm haveing is I'm dealing with over 35000 records and the time it takes to run the query is too long. If there is a better way of do this I will definitely give it a try. Thanks!
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
If Not (rst.EOF And rst.BOF) Then
Do While Not rst.EOF
If rst("HolidayDate") = NextBusDay Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
rst.MoveNext
Loop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End Function
Here is one solution to avoid the opening the Holiday table 35,000 times. It will load all dates into an Array (only once), then use that array for comparing. But I am curious if your existing process ever worked correctly 100% of the time -- if that table contained more than one holiday? Specifically, when you read the holiday table (regardless of the sort order), then in your loop "If rst("HolidayDate") = NextBusDay Then", since you don't exit the loop if you get a match, your subroutine should always return the results of what happens when checking the last date in the table? Also I didn't find a Dim for NextBusDay, so I added it.
Option Compare Database
Option Explicit
Public blnSetArray As Boolean
Public dHolidays() As Date
Public iHolidays As Integer
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Dim i As Integer
Dim iLoop As Integer
Dim NextBusDay As Date
' Save an array of dates the first time
If blnSetArray = False Then
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
i = 0
If Not (rst.EOF And rst.BOF) Then
rst.MoveLast
rst.MoveFirst
iHolidays = rst.RecordCount
ReDim dHolidays(rst.RecordCount)
Do While Not rst.EOF
i = i + 1
dHolidays(i) = rst("HolidayDate")
rst.MoveNext
Loop
End If
blnSetArray = True
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End If
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
HolidayInterest = 0 ' Set as default
If iHolidays > 0 Then
For iLoop = 1 To iHolidays
If dHolidays(iLoop) = NextBusDay Then
HolidayInterest = Perdiem
Exit For ' No need to stay in loop
End If
Next iLoop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
End Function
Function MyTest()
blnSetArray = False
Debug.Print HolidayInterest(100#)
End Function
Apart from the Perdiem value you pass as an argument to your function, the only thing that will affect the return value of your function is the current system date as returned by Date. In other words, on any given day your function will always return either the Perdiem value or zero.
Therefore, we can use a Static variable named TheDateToday to hold the current date and you will only have to hit the [tbl_Holidays] table once on any given day:
Option Compare Database
Option Explicit
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim NextBusDay As Date
Static TheDateToday As Date, NextBusDayIsHoliday As Boolean
If CLng(TheDateToday) <> CLng(Date) Then
TheDateToday = Date
Select Case DatePart("w", TheDateToday)
Case 6
NextBusDay = DateAdd("d", 3, TheDateToday)
Case 7
NextBusDay = DateAdd("d", 2, TheDateToday)
Case Else
NextBusDay = DateAdd("d", 1, TheDateToday)
End Select
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", _
"PARAMETERS prmDate DateTime;" & _
"SELECT * FROM tbl_Holidays WHERE HolidayDate=[prmDate]")
qdf!prmDate = NextBusDay
Set rst = qdf.OpenRecordset(dbOpenSnapshot)
NextBusDayIsHoliday = Not (rst.EOF And rst.BOF)
rst.Close
Set rst = Nothing
Set qdf = Nothing
Set db = Nothing
End If
If NextBusDayIsHoliday Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
End Function
When there is only one record, this expression gives correct calculation, but when there are more than one record the values of last record calculated is reflected in all Total_Time (unbound text box).I have given on load and on open code of the report. Please help me.
Private Sub Report_Load()
strSQL = "SELECT * FROM [q_1ltduty]"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
rs.MoveFirst
Do While Not rs.EOF
'Assigning values of fields to varia
strtime1 = Op_Time
strtime2 = Cl_Time
'This is a simple expression my code has some more detailed calculations
strhrs = strtime2 - strtime1
strtotalhrs = strhrs
'Printing the variable in Total_Time textbox(unbound)
Me.Total_Time.Value = strtotalhrs
rs.MoveNext
Loop
rs.Close
db.Close
Set db = Nothing
Set rs = Nothing
End Sub
Private Sub Report_Open(Cancel As Integer)
strSQL = "SELECT * FROM [q_1ltduty]"
Me.RecordSource = strSQL
Debug.Print strSQL
Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub
Your variable strtotalhrs contains only the value of strhrs for one record, so each time you go through the loop, the value for the current record erases the value for the previous record. What you should do instead of erasing the value is adding to it.
Before the loop (if it has not already been done):
strtotalhrs = 0
then in the loop, instead of strtotalhrs = strhrs:
strtotalhrs = strtotalhrs + strhrs
and that should give you the sum total instead of the last value.