Loop in VBA Skipping Values - ms-access

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

Related

Runtime Error 3061 too few parameters expected 1 DAO declarations

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]

VB6 Assigning data to variables from a database

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
'...

Getting an error when trying to read all rows of a recordset

I created a query separately and now want to use VBA to read its records and then send certain fields of all rows in an email.
I am currently stuck on trying to extract all the rows from the recordset. I know how to do it for one record, but not with a dynamic recordset. Every week, the recordset could potentially have 1-10 (approx.) records. I had hoped to do this by dynamically reading all rows, saving the fields that I want into variables, and then adding that to the email body, but I arrived at an error.
I'm getting an error that says: Run-time error '3265': Item not found in this collection.
Does anyone know how to fix this error and how I can put all resulting rows of the recordset into the email body?
The code:
Private Sub Form_Timer()
'current_date variable instantiated in a module elsewhere
current_date = Date
'Using the Date function to run every Monday, regardless of the time of day
If current_date = (Date - (DatePart("w", Date, 2, 1) - 1)) Then
'MsgBox ("the current_date variable holds: " & current_date)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim varRecords As Variant
Dim intNumReturned As Integer
Dim intNumColumns As Integer
Dim intColumn As Integer
Dim intRow As Integer
Dim strSQL As String
Dim rst_jobnumber As String
Dim rst_bfloc As String
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_BMBFLoc")
Set rst = qdf.OpenRecordset
If rst.EOF Then
MsgBox "Null."
Else
'Found this part of the code online and not sure if I'm using it right.
varRecords = rst!GetRows(3)
intNumReturned = UBound(varRecords, 2) + 1
intNumColumns = UBound(varRecords, 1) + 1
For intRow = 0 To intNumReturned - 1
For intColumn = 0 To intNumColumns - 1
Debug.Print varRecords(intColumn, intRow)
Next intColumn
Next intRow
'End of code found online.
'rst.MoveFirst 'commenting this out because this query could potentially return multiple rows
rst_jobnumber = rst!job & "-" & rst!suffix
rst_bfloc = rst!Uf_BackflushLoc
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
'Dim oApp As Outlook.Application
'Dim oMail As MailItem
'Set oApp = CreateObject("Outlook.application")
'mail_body = "The following jobs do not have the special BF location set in Job Orders: " & rst_
'Set oMail = oApp.CreateItem(olMailItem)
'oMail.Body = mail_body
'oMail.Subject = "Blow Molding Jobs Missing BF Location"
'oMail.To = "something#something.com" 'in the future, create a function that finds all of the SC users' emails from their Windows user
'oMail.Send
'Set oMail = Nothing
'Set oApp = Nothing
End If
End If
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Try working with this code and see how it works for you. I was unsure if you were sending one email per or one email listing all (I assumed the latter)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strMessageBody As String
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset("qry_BMBFLoc")
strMessageBody = "The following jobs do not have the special BF location set in Job Orders: "
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
strMessageBody = strMessageBody & rst!job & "-" & rst!suffix & ","
rst.MoveNext
Loop
If Right(strMessageBody, 1) = "," Then strMessageBody = Left(strMessageBody, Len(strMessageBody)-1)
End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
EDIT - not using dot operator
Replace
varRecords = rst!GetRows(3)
with
varRecords = rst.GetRows(3)
Do you have three rows in your recordset?
If not rst!GetRows(3) will return false - and then next line will fail when you try to use UBound.
A good example of how to implement GetRows
Another possibility is if you're trying to access a Field that's not in your recordset on a line that has rst!

MS Access compare a value to a table column and return a field from the same row

Ok so i have a complex reason field from one of our logging servers, and i need to break it down to make some sense, problem is the format changes depending on the status.
I managed to find some strings that i can compare the the reason to to get some sense out of it, but I want to distill it down to one reason code.
I scratched my head a bit and got it down to 7 reasons with different criterion, put the criteria in a table and came up with some vb code to do the comparison.
Problem is its dead slow, and half the reporting relies on the Reason code. The basic VBA function is below, This basically loads the criteria into an array and then compares the value against the array to return the ID.
Function Reason_code(LongReason As String) As Integer
Dim NoReason As Integer
Dim I As Integer
Dim J As Integer
Dim x As Boolean
NoReason = recordCount("RejReason") - 1
Dim conExpr() As String
ReDim conExpr(NoReason)
For I = 0 To (NoReason - 1)
conExpr(I) = GetVal("Criterior", "RejReason", "id", CStr(I + 1))
Next I
For J = 0 To (NoReason - 1)
x = LongReason Like conExpr(J)
If x = True Then
GoTo OutOfLoop
End If
Next J
OutOfLoop:
Reason_code = J + 1
End Function
I have used similar in VB before and it tends to be quite fast, so i am reconing that my GetVal function is the problem, but my VBA is rusty and my SQL is pretty non existent, so any help would be appreciated. I tried LSQL and SQL2 as one line but VBA doesnt like it.
Function GetVal(FieldNm As String, TableNm As String, IndexField As String, IndexNo As String) As String
Dim db As Database
Dim Lrs As DAO.Recordset
Dim LSQL As String
Dim LGST As String
Dim SQL2 As String
'Open connection to current Access database
Set db = CurrentDb()
'Create SQL statement to retrieve value from GST table
LSQL = CStr("SELECT " + FieldNm + " FROM " + TableNm)
SQL2 = CStr(LSQL + " WHERE " + IndexField + " = " + IndexNo)
Set Lrs = db.OpenRecordset(SQL2, dbOpenDynaset, dbReadOnly)
'Retrieve value if data is found
If Lrs.EOF = False Then
LGST = Lrs(0)
Else
LGST = "Item Not found"
End If
Lrs.Close
Set Lrs = Nothing
GetVal = LGST
End Function
Thanks in advance,
I Scratched my head for a bit and worked out i could speed it up by doing the read and compare at the same time, its not lightning, but its better
Function ReasonCode(LongReason As String) As String
Dim cdb As Database
Dim rs As DAO.Recordset
Dim RejRea()
Dim NoReason As Integer
Dim result As Boolean
Dim i As Integer
Set cdb = CurrentDb()
Set rs = cdb.OpenRecordset("RejReason", dbOpenDynaset, dbReadOnly)
rs.MoveLast
rs.MoveFirst
NoReason = rs.recordCount - 1
RejRea() = rs.GetRows(rs.recordCount)
For i = 0 To NoReason
result = LongReason Like CStr(RejRea(2, i))
If result = True Then
ReasonCode = CStr(RejRea(1, i))
GoTo outloop
End If
Next i
If ReasonCode = "" Then ReasonCode = "Not Found"
outloop:
Set rs = Nothing
Set cdb = Nothing
End Function
Still not sure its the best way to do it, but in the abscence of any other suggestions it will do for now.

How to search a field in a table in Access

Using VBA, how can I search for a text string, for example "CHIR", in a table called "ServiceYES", in the field "Service".
After that, I would like to save the neighboring field for all the rows that "CHIR" exists in the table "ServicesYES". The "ServiceYES" table is below:
I basically, want to find all the "CHIR" in "Service" column and then save the names which are on the left of the CHIR, eg "FRANKL_L", "SANTIA_D" as an array.
Thanks for all your help in advance.
Start by creating a SELECT query.
SELECT Code_Perso
FROM ServicesYES
WHERE Service = 'CHIR';
Use SELECT DISTINCT Code_Perso if you want only the unique values.
Add ORDER BY Code_Perso if you care to have them sorted alphabetically.
Once you have a satisfactory query, open a DAO recordset based on that query, and loop through the Code_Perso values it returns.
You don't need to load them directly into your final array. It might be easier to add them to a comma-separated string. Afterward you can use the Split() function (assuming you have Access version >= 2000) to create your array.
Here's sample code to get you started. It's mostly standard boiler-plate, but it might actually work ... once you give it "yourquery".
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strItems As String
Dim varItems As Variant
Set db = CurrentDb
Set rs = db.OpenRecordset("yourquery", dbOpenSnapshot)
With rs
Do While Not .EOF
strItems = strItems & "," & !Code_Perso
.MoveNext
Loop
.Close
End With
If Len(strItems) > 0 Then
' discard leading comma '
strItems = Mid(strItems, 2)
varItems = Split(strItems, ",")
Else
MsgBox "Oops. No matching rows found."
End If
Set rs = Nothing
Set db = Nothing
I tested this and it seems to work. This function will pull all records where ServiceYes='CHIR' and dump the Code_Person value into an array which it will return:
Function x() As String()
Dim rst As Recordset
Set rst = CurrentDb.OpenRecordset( _
"Select * from ServiceYES where Service='CHIR'")
Dim Arr() As String
Dim i As Integer
While rst.EOF = False
ReDim Preserve Arr(i)
Arr(i) = rst.Fields("Code_Person")
i = i + 1
rst.MoveNext
Wend
x = Arr
End Function
Sample Usage:
Debug.Print x()(0)
Paolo,
Here is something I threw together in a few minutes. You can add it to the VBA editor in a module. It uses a trick to get the RecordCount property to behave properly. As for returing the array, you can update the function and create a calling routine. If you need that bit of code, just post a comment.
Thanks!
Option Compare Database
Function QueryServiceYES()
Dim db As Database
Dim saveItems() As String
Set db = CurrentDb
Dim rs As DAO.Recordset
Set rs = db.OpenRecordset("SELECT Code_Perso, Service, Favorites " & _
"FROM ServiceYES " & _
"WHERE Service = 'CHIR'")
'bug in recordset, MoveFirst, then MoveLast forces correct invalid "RecordCount"
rs.MoveLast
rs.MoveFirst
ReDim Preserve saveItems(rs.RecordCount) As String
For i = 0 To rs.RecordCount - 1
saveItems(i) = rs.Fields("Code_Perso")
rs.MoveNext
Next i
'print them out
For i = 0 To UBound(saveItems) - 1
Debug.Print saveItems(i)
Next i
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Function