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
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'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
'...
So I have the following code in Access:
Dim db As DAO.Database
Dim qdEPH As DAO.QueryDef
Dim rsEPH As DAO.Recordset
Set qdEPH = DBEngine(0)(0).QueryDefs("MyQuery")
qdEPH.Parameters(0) = Text10.Value
Set db = CurrentDb
Set rsEPH = qdEPH.OpenRecordset
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add
Set oSheet = oBook.Worksheets("Sheet1")
oSheet.Activate
Dim Count as Long
Count = 1
Do While Not rsEPH.EOF
oSheet.Range("A" & Count).Value = rsEPH("Value1")
Count = Count + 1
rsEPH.MoveNext
Loop
A user puts a value in textbox Text10 on a form and clicks a button to run the code above. It runs the query MyQuery and dumps the results into a recordset named rsEPH. One of the fields, Value1, is stored as a text value in the table being queried. However, it's actually a number. How can I convert rsEPH("Value1") to a number (returning Null or something if it fails) and then divide it by 100?
Use Nz to transform Nulls in the text field before you apply the numeric conversion function. I chose CDbl as the conversion function.
oSheet.Range("A" & Count).Value = CDbl(Nz(rsEPH("Value1"), "0"))
But you mentioned dividing by 100, so maybe you want this ...
oSheet.Range("A" & Count).Value = CDbl(Nz(rsEPH("Value1"), "0")) / 100
Try below code
Do While Not rsEPH.EOF
oSheet.Range("A" & Count).Value = IIf(IsNull(rsEPH("Value1")), 0, CDbl(rsEPH("Value1")))
Count = Count + 1
rsEPH.MoveNext
Loop
hi guys im trying to take the value of data(0)
and put it into say variable InvoiceNumber. I tried putting an image of my watch screen but i ended up not being allow. but here is what my watch screen would look like.
data
data(0)
data(0,1) 1
data(0,2) 2
data(0,3) 3
I have tried
dim InvoiceNumber as variant <br/>
invoiceNumber = data(0)
but i keep getting error. I dont know how to reference just the part of that array. any help would be greatly appreciated.
here is the full code for anyone that would like to see a little more.
Dim db As Database
Dim rs As Recordset
Dim data As Variant
Dim colummn1 As Variant
Dim obj As Object
Set db = CurrentDb
Set rs = db.OpenRecordset("select * from Table1")
'set obj = new object
While Not rs.EOF
'MsgBox (rs.RecordCount)
'MsgBox (rs.Fields.Count)
data = rs.GetRows(rs.Fields.Count)
Column1 = data.data(0)
Wend
rs.Close
db.Close
End Sub
Try
Column1 = data(0,0)
instead of
Column1 = data.data(0)
data contains a two-dimensional array. The fist index is the field number, the second index is the row number. Both start at zero. So data(0,0) is the first field of the first row. data(1,0) is the second field of the first row.
I would try to make an array of invoices by using a user defined type
Public Type Invoice
Nr As Variant
IssueDate As Variant
Total As Variant
'Or whatever your invoice contains
End Type
Public Sub TestGetRecords()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim data As Variant
Dim numRecords As Long, i As Long
Dim Invoices() As Invoice
Set db = CurrentDb
Set rs = db.OpenRecordset("select * from Table1")
data = rs.GetRows()
rs.Close
db.Close
numRecords = UBound(data, 2) + 1
ReDim Invoices(0 To numRecords - 1) As Invoice
For i = 0 To numRecords - 1
Invoices(i).Nr = data(0, i)
Invoices(i).IssueDate = data(1, i)
Invoices(i).Total = data(2, i)
Next i
Debug.Print Invoices(0).Total
End Sub
An error in you solution is, that you placed GetRows in a loop. However, GetRows returns all the rows at once!
I am finding it a little hard to understand what you are trying to achieve.
You are reading an entire table of data into a recordset object, loading the fields of the recordset object into a two dimensional array and then trying to iterate through the array to output the results to a single variable (or a sum of array values).
Why don't you just use an SQL expression to extract the data directly from your table?
If we can assume you have a table of invoices (say ... "myInvoiceTable") with at least the following fields ...
invoiceID
invoiceValue
(and probably many others, eg. invoiceDate, clientID, etc.)
you can write an expression something like this
"SELECT SUM(invoiceValue) AS MyTotal FROM myInvoiceTable WHERE invoiceID > xxxx"
This might go into your VBA code like this.
Dim rst as Recordset
Dim strSQL as string
strSQL = "SELECT SUM(invoiceValue) AS MyTotal FROM myInvoiceTable WHERE invoiceID > 400" '-- use an appropriate WHERE clause if needed
Set rst = CurrentDb.Openrecordset(strSQL) '-- the rst object should contain a single value "MyTotal" which is the sum of the fields you are trying to access
MsgBox rst!MyTotal '-- use this value wherever you need to use it
I'm assigning an Access 2007 query to a QueryDef in Excel VBA. My query calls a user-defined function, because it performs a calculation on the results of evaluating a field with a regular expression. I'm using a QueryDef because I'm collecting values in a UserForm and want to pass them to the query as parameters.
When I run my VBA code, I get an error: "Run-time error '3085': Undefined function 'regexFunc' in expression."
This question suggests that the problem is that DAO is unable to call Access UDFs from Excel, so I copied my UDF into the Excel VBA module, but I still get the error.
Access query:
select field1 from dataTable where regexFunc(field1)=[regexVal]
Here's the Excel VBA code:
'QueryDef function
Sub makeQueryDef (str As String)
Dim qdf As QueryDef
Dim db As Database
Set db = OpenDatabase(DBpath)
Set qdf = db.QueryDefs("paramQuery")
qdf.Parameters("regexVal") = (str="test")
doSomething qdf
End Sub
'Regex function copied from Access VBA module to Excel VBA module
Function regexFunc(str As String) As Boolean
Dim re As RegExp
Dim matches As MatchCollection
regexFunc = False
Set re = New RegExp
re.Pattern = "\reg[ex](pattern)?"
Set matches = re.Execute(str)
If matches.Count <> 0 Then
regexFunc = True
End If
End Function
This is how I would do it... just tested it and it works fine with my UDF:
One thing - are you required to not use New Access.Application?
Sub GetMyDataWithUDF()
Dim oApp As Access.Application
Dim qd As QueryDef
sFileName = "C:\Users\AUser\Desktop\adatabase.mdb"
Set oApp = New Access.Application
oApp.OpenCurrentDatabase (sFileName)
Set qd = oApp.CurrentDb.QueryDefs("Query1")
If oApp.DCount("*", "MSysObjects", "Name='dataTableResults'") > 0 Then _
oApp.CurrentDb.TableDefs.Delete "dataTableResults"
qd.Parameters("avalue") = "4"
qd.Execute
oApp.Quit
Set oApp = Nothing
Dim oRS As ADODB.Recordset
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFileName & ";User Id=admin;Password=;"
Set oRS = New ADODB.Recordset
oRS.Open "SELECT * FROM dataTableResults", sConn
Sheet1.Cells.Clear
Sheet1.Range("A1").CopyFromRecordset oRS
oRS.Close
Set oRS = Nothing
End Sub
Note that I made my underlying query a SELECT ... INTO query that creates a table called 'dataTableResults'
This is my query (QueryDef) in Access:
SELECT dataTable.Field1, dataTable.Field2 INTO dataTableResults
FROM dataTable
WHERE mysqr(dataTable.Field1)=[avalue];
My MS-Access DB has a function called "mysqr", which gets used in the SQL above.
Function mysqr(Num)
mysqr = Num * Num
End Function
The table "dataTable" I'm querying against is just a list of numbers, so if my parameter "avalue" is "16", then I get the row "4" back. If I enter "4" (as in my code), I get "2" back.
I've solved this. Here's how I did it.
First I change the query into a recordset and pass it to my filtering function:
function filteredQDF(qdf As QueryDef, boolVal As Boolean) As Variant
Dim rs As Recordset
Dim rows_rs As Variant
Dim rs_new As Recordset
Dim filtered As Variant
Set rs = qdf.OpenRecordset
rs.MoveLast
rs.MoveFirst
rows_rs = rs.GetRows(rs.RecordCount)
rows_rs = Application.WorksheetFunction.Transpose(rows_rs)
filtered = filterFunction(rows_rs, boolVal)
filteredQDF = filtered
End Function
And here's the filtering function, which creates a new array, populates it with rows that pass the UDF's boolean check, and returns it:
Function filterFunction(sourceArray As Variant, checkValue As Boolean) As Variant
Dim targetArray As Variant
Dim cols As Long
Dim targetRows As Long
Dim targetCursor As Long
'get # of columns from source array
cols = UBound(sourceArray, 2)
'count total number of target rows because 2D arrays cannot Redim Preserve
'checking sourceArray(r,2) because that's the criterion column
targetRows = 0
For r = 1 To UBound(sourceArray, 1)
If myUDF(CStr(sourceArray(r, 2))) = checkValue Then
targetRows = targetRows + 1
End If
Next
'set minimum target rows to 1 so that function will always return an array
If targetRows = 0 Then
targetRows = 1
End If
'redim target array with target row count
ReDim targetArray(targetRows, cols)
'set cursor for assigning values to target array
targetCursor = 0
'iterate through sourceArray, collecting UDF-verified rows and updating target cursor to populate target array
For r = 1 To UBound(sourceArray, 1)
If myUDF(CStr(sourceArray(r, 2))) = checkValue Then
For c = 1 To cols
targetArray(targetCursor, c - 1) = sourceArray(r, c)
Next
targetCursor = targetCursor + 1
End If
Next
'assign return value
filterFunction = targetArray
End Function