I am trying to ad an event counter to a table.
The table contains some data about events organized by the subject of an event (NR_U) and subsequet period (C_ID).
The counter should count the number of periods since the last event defined as (D_Z>90 and K_Z>200) for all subjects and periods in the table.
I wrote the following, but at the rs.update.
I get run time error 3251:
The current recordset does not allow update.
How do I fix it, so the records can be updated?
Private Sub update_default()
Dim Conn1 As New ADODB.Connection
Dim Cmd1 As New ADODB.Command
Dim Errs1 As Errors
Dim Rs As New ADODB.Recordset
Dim s As String
Dim un As String
Dim m As Double
Set Conn1 = CurrentProject.Connection
s = "SELECT * FROM MAIN order by MAIN.NR_U, MAIN_4.C_ID;"
un = "nothing"
Set Rs = Conn1.Execute(s)
While Not Rs.EOF
If Rs!NR_U = un Then
If (Rs!D_Z > 90 And Rs!K_Z > 200) Then
m = 1
Else
m = IIf(m > 0, m + 1, 0)
m = IIf(m >= 12, 0, m)
End If
Else
un = Rs!NR_U
m = 0
If (Rs!D_Z > 90 And Rs!K_Z > 200) Then
m = 1
End If
End If
Rs!D_C_12M = m
Rs.update
Rs.MoveNext
Wend
End Sub
OK, I've managed to solve the problem. Instead of
"Rs.Execute(s)" I've used "Rs.Open s, Conn1, adOpenForwardOnly, adLockOptimistic" and evrything worked just fine.
Related
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]
i have a process that will update the records of the material. but first it will get the existing records of the material like avail quantity before updating and when i try to update it with the new one. i get an error saying "Run-time error ‘-2147217864(80040e38)’: Row cannot be located for updating. Some values may have been changed since it was last read."
Dim rs As New ADODB.Recordset
Set rs = New ADODB.Recordset
Dim coy As String
If Left(Text4.Text, 3) = "800" Then
For i = 1 To ListView2.ListItems.Count
With ListView2.ListItems(i)
If rs.State <> 0 Then rs.Close
rs.Open "Select * from Inventory where InventoryID = " & Val(.ListSubItems(6).Text), db, 3, 3
If rs.RecordCount <> 0 Then
'get average cost start
Dim avgcost, Stockqty, newstockqty As Double
Stockqty = CDbl(rs!AvailQty) * CDbl(rs!unitprice)
newstockqty = CDbl(.ListSubItems(7).Text) * CDbl(.ListSubItems(8).Text)
avgcost = (Stockqty + newstockqty) / CDbl(CDbl(rs!AvailQty) +
CDbl(.ListSubItems(7).Text))
'get average cost end
rs!avecost = FormatNumber(avgcost, 3)
avaiqtyparam = CDbl(rs!AvailQty) + CDbl(.ListSubItems(7).Text)
rs!AvailQty = CDbl(rs!AvailQty) + CDbl(.ListSubItems(7).Text)
rs!unitprice = FormatNumber(CDbl(.ListSubItems(8).Text), 5)
rs!lastupdate = FormatDateTime(DTPicker1.Value, vbShortDate)
Dim AvgVat, stockvat, nestockvat As Double
stockvat = CDbl(rs!AvailQty) * CDbl(rs!AvailVAT)
nestockvat = CDbl(.ListSubItems(7).Text) * CDbl(.ListSubItems(11).Text)
AvgVat = (stockvat + nestockvat) / CDbl(CDbl(rs!AvailQty) +
CDbl(.ListSubItems(11).Text))
rs!AvailVAT = CDbl(.ListSubItems(11).Text)
rs!AveVAT = FormatNumber(AvgVat, 3)
rs.Update
End If
End With
rs.Close
Set rs = Nothing
Next i
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
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.
In a query I have an SQL iif statement that incorporates too many iif, therefore I cannot add any more iif, which is a problem.
To solve the problem, I had the idea to code a VBA function, but I am facing difficulties. Here is what I have, with a simple example where we have a Number in a field. In case the number is <0, the function Retrive() should retrieve the value of field TheDate, in case >0 the function should retrieve the value of the field TheOtherDate:
Public Function Retrive(NumberToCheck As Integer) As Date
Dim db As Database
Dim r As Recordset
Dim rsCount As Integer
Dim TheDate As Field, TheOtherDate As Field
Dim i As Integer
Set db = CurrentDb()
Set r = db.OpenRecordset("Table")
Set TheDate = r.Fields("TheDate")
Set TheOtherDate = r.Fields("TheOtherDate")
rsCount = r.RecordCount
r.MoveFirst
For i = 1 To rsCount
If NumberToCheck < 0 Then
Retrive = TheDate.Value
End If
If NumberToCheck > 0 Then
Retrive = TheOtherDate.Value
End If
r.MoveNext
Next i
End Function
But this does not work because it retrieves the last record for each line, not the right lines.
Your For loop just keeps running until you reach the last record and then exits. You have to jump out of the loop when you reach the correct record (you decide how to determine this).
Option Explicit
Public Function Retrive(NumberToCheck As Integer) As Date
Dim db As Database
Dim r As Recordset
Dim rsCount As Integer
Dim TheDate As Field, TheOtherDate As Field
Dim TheRightDate As Date
Dim i As Integer
Set db = CurrentDb()
Set r = db.OpenRecordset("Table")
Set TheDate = r.Fields("TheDate")
Set TheOtherDate = r.Fields("TheOtherDate")
rsCount = r.RecordCount
r.MoveFirst
TheRightDate = DateValue("1/15/2015")
For i = 1 To rsCount
If NumberToCheck < 0 Then
Retrive = TheDate.Value
'--- check here to see if you have the correct value
' and if so, the exit the loop
If Retrive = TheRightDate Then
Exit For
End If
End If
If NumberToCheck > 0 Then
Retrive = TheOtherDate.Value
'--- check here to see if you have the correct value
' and if so, the exit the loop
If Retrive = TheRightDate Then
Exit For
End If
End If
r.MoveNext
Next i
End Function