Looping through an array and posting array to table - ms-access

I am an old Foxpro programmer and I use to use arrays to post variable fields.
What I am trying to do is I have 15 date fields in the new table I designed.
In my query I have individual records with one date for activity.
I want to compile the 15 different dates for a each Client_id into one record with 15 dates but I can't seem to reference the table data as an array.
I have tried a couple different methods of defining the array but nothing seems to work.
Here is my code that I have. In my table I have 15 date fields named Mail_date1, Mail_date2, Mail_date3, etc.
I tried first defining it just as an array but did not like it; my code always fails when I try to reference the date field in the result table rs2!mdate2 = memdate(intcounter)
How can I reference my result table output fields as an array?
Do I have to put a whole bunch of if statements to load my results?
Seems like a waste.... should be able to load them as an array.
I am a new Access 2007 VBA programmer.
Dim db As DAO.Database
Set db = CurrentDb
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim FinTotal, intcounter As Integer
Dim FinMPU, FinVersion As String
Dim mail_date(1 To 15) As Date
Dim memdate(1 To 15) As Date
Dim mdate2 As String
Set rs1 = db.OpenRecordset( _
"SELECT NewFile.MPU_ID, " & _
" NewFile.MAIL_DATE," & _
" NewFile.TOTAL, " & _
" Freight.Version " &_
"FROM Freight " & _
" LEFT JOIN NewFile ON Freight.[MPU ID] = NewFile.MPU_ID " & _
"ORDER BY NewFile.MPU_ID, NewFile.MAIL_DATE")
Set rs2 = db.OpenRecordset("Final")
DoCmd.RunSQL "DELETE Final.* FROM Final;"
intcounter = 1
memdate(intcounter) = rs1!mail_date
FinMPU = rs1!mpu_ID
FinTotal = rs1!total
FinVersion = rs1!Version
rs1.MoveNext
On Error GoTo Error_MayCauseAnError
Do While Not rs1.EOF
Do While Not rs1.EOF _
And memdate(intcounter) <> rs1!mail_date _
And FinMPU = rs1!mpu_ID
intcounter = intcounter + 1
memdate(intcounter) = rs1!mail_date
FinTotal = FinTotal + rs1!total
FinVersion = rs1!Version
FinMPU = rs1!mpu_ID
rs1.MoveNext
Loop
If FinMPU <> rs1!mpu_ID Then
rs2.AddNew
mdate2 = "mail_date" & CStr(intcounter)
rs2!mdate2 = memdate(intcounter)
rs2!total = FinTotal
rs2!mpu_ID = FinMPU
rs2!Version = FinVersion
rs2.Update
FinTotal = rs1!total
FinVersion = rs1!Version
FinMPU = rs1!mpu_ID
intcounter = 1
memdate(intcounter) = rs1!mail_date
End If
rs1.MoveNext
Loop

first, if you expect and answer, you should really spend more time on properly formatting your explanation and your code...
Now, for some remarks and possible answer to the question:
You should DELETE FROM Final before you open that table in a recordset.
You should be explicit about the type of recordset you are opening:
' Open as Read-only '
Set rs1 = db.OpenRecordSet("...", dbOpenSnapshot)
' Open as Read/Write '
Set rs1 = db.OpenRecordSet("...", dbOpenDynaset)
You should Dim memdate(1 To 15) As Variant instead of Date as the Date datatype cannot be Null, and since you are pulling data from a LEFT JOIN, it's possible that the returned values could be Null if there are no corresponding data to Freight in the table Newfile.
That On Error GoTo Error_MayCauseAnError should probably not be there.
Use On Error Goto only to catch errors you can't deal with at all.
Using that here will only hide errors in your code. With some proper checks statements you should not even need the On Error Goto...
It looks like your first internal loop is trying to skip some records.
However, when that loop breaks, it could be because it reached EOF, and you never test for that in the code that follows the loop.
You never test if your intcounter goes beyond the 15 allocated dates.
Are you absolutely sure that you can never have more than 15 records?
You do not say which error message you get exactly. That could be useful to help determine the kind of issue at hand.

Instead of
mdate2 = "mail_date" & CStr(intcounter)
rs2!mdate2 = memdate(intcounter)
Use
rs2.Fields("mail_date" & intcounter).Value = memdate(intcounter)
the ! syntax of DAO really only is a shorthand for the longer rs.Fields("name") form.

Related

Doing a compare between field and variable in MS access - does not find match

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, "")
...

In VBA Query cannot be completed

I want to find the sum of records from different tables and insert the output in a new column, when I run the code it show me the error:
"The query cannot be completed. Either the size of the query result is
larger than the maximum size of the database (2GB) or there is not enough
temporary storage space on the disk to store the query result"
And it highlight the line
STD.Open sql, cnn, adOpenStatic
My code is the following
Option Compare Database
Option Explicit
Public cnn As New ADODB.Connection
Public db As DAO.Database
Public Sub SMain()
Set db = Access.Application.CurrentDb
Set cnn = CurrentProject.Connection
Get_Value
End Sub
Private Sub Get_Value()
Dim sql As String
Dim STD As New ADODB.Recordset
Dim ODR As DAO.Recordset
Set ODR = db.OpenRecordset("Total_tbl")
Do Until ODR.EOF
DoEvents
sql = "SELECT SUM(MONT_VOL.tot_n* STD_tbl.factor_n)AS TOTAL_N FROM MONT_VOL " & _
" INNER JOIN (STD_tbl INNER JOIN Total_tbl ON STD_tbl.AREA =Total_tbl.AREA_1" & _
" AND STD_tbl.AID = Total_tbl.AID)" & _
" ON MONT_VOL.BID = STD_tbl.BLOCK" & _
" WHERE MONT_VOL.BDATE = Total_tbl.Adate" & _
" GROUP BY MONT_VOL.BID"
STD.Open sql, cnn, adOpenStatic
If STD.RecordCount <> 0 Then
ODR.Edit
ODR!New_Col= STD!TOTAL_N
ODR.Update
End If
STD.Close
ODR.MoveNext
Loop
End Sub
What mistake I did?
And am I calling the output correctly on
ODR!New_Col= STD!TOTAL_N
If the query is too big (which the error message indicates), then let's split it into smaller chunks. This is only properly possible in MySQL, Access doesn't support LIMIT or OFFSET, workarounds are messy, especially for totals queries
I'm making a few assumptions here:
All relevant tables are stored within the same MySQL database
Your tables have valid connection strings that can be used for ADO
Note that executing the query in MySQL alone is probably enough to fix this error.
Private Sub Get_Value()
Dim sql As String
Dim STD As New ADODB.Recordset
Dim ODR As DAO.Recordset
Set ODR = db.OpenRecordset("Total_tbl")
'Create a new ADODB connection that's directly to MySQL, and doesn't use Access
Dim adoConn2 As ADODB.Connection
adoConn2.ConnectionString = CurrentDb.TableDefs("MONT_VOL").Connect
adoConn2.Open
'Initialize variables used for pagination
Dim RecordCount As Integer
Dim PageSize As Integer
Dim Offset As Integer
Offset = 0
RecordCount = 1
PageSize = 100
Do Until ODR.EOF
DoEvents
While RecordCount <> 0
sql = "SELECT SUM(MONT_VOL.tot_n* STD_tbl.factor_n)AS TOTAL_N FROM MONT_VOL " & _
" INNER JOIN (STD_tbl INNER JOIN Total_tbl ON STD_tbl.AREA =Total_tbl.AREA_1" & _
" AND STD_tbl.AID = Total_tbl.AID)" & _
" ON MONT_VOL.BID = STD_tbl.BLOCK" & _
" WHERE MONT_VOL.BDATE = Total_tbl.Adate" & _
" GROUP BY MONT_VOL.BID" & _
" LIMIT " & Offset & "," & PageSize
STD.Open sql, adoConn2, adOpenStatic
RecordCount = STD.RecordCount
If STD.RecordCount <> 0 Then
ODR.Edit
ODR!New_Col = STD!TOTAL_N
ODR.Update
End If
STD.Close
Offset = Offset + PageSize
Wend
ODR.MoveNext
Loop
adoConn2.Close
End Sub

Check array for unique values and output csv

I need to loop through an Access query, find all the unique values from a field (in this case called UtilityDunsNumber), put them into an array and then run another query for each DunsNumber in that array and output a CSV file with all the records from that new query, then loop back through to create a file for each DunsNumber.
Here's the code I have thus far:
Private Sub Command0_Click()
Dim db As DAO.Database
Dim records() As DAO.Recordset
Dim duns() As String
Dim i As Integer
Dim fs As String
fs = "C:\TestECI\IN_572_COMPANY_" & Format(Now(), "yyyymmdd") & "_814EN01_"
Set records = db.OpenRecordset("SELECT * FROM qry_RequestECI")
'loop through records, get list of unique DUNS numbers
'get unique duns
For Each Record In records
If IsInArray(Record.UtilityDunsNumber, duns) Then
continue
Else
ReDim Preserve duns(1 To UBound(duns) + 1) As String
' add value on the end of the array
arr(UBound(arr)) = Record.UtilityDunsNumber
End If
Next
For Each UtilityDunsNumber In duns
Set records = db.OpenRecordset("SELECT * FROM qry_RequestECI WHERE UtilityDunsNumber =" & dun)
i = 2000
fs = fs & i & ".csv"
DoCmd.TransferText acExportDelim, , records, fs, True
i = i + 1
Next
End Sub
It is failing here:
Set records = db.OpenRecordset("SELECT * FROM qry_RequestECI")
with the error
"Can't assign to array"
Dim records() As DAO.Recordset
Here you're declaring an array of recordsets...
Dim records As DAO.Recordset
Is probably what you want.
There's a simplification that may or may not help. To get the list of Duns numbers, you can use
set DunsRS=db.openrecordset "select UtilityDunsNumber from qry_RequestECI group by UtilityDunsNumber"
And then you can loop through the list with
DunsRS.movefirst
do while not DunsRS.eof
dun = DunsRS.fields("UtilityDunsNumber").value
...
...
DunsRS.movenext
Loop
This might be enough to fix the problem - not sure without trying it.

VBA Access getting RowSource to find lookup values

VBA noob here (as of this mourning),
In MS Access I wrote a test function to find the value of a record base on some criteria you pass in.
The function seems to work fine except in cases where there is a lookup in the column that I am searching.
Basically it might return "19" and 19 corresponds to some other table value.
It seems that the RowSource of the column is what Im after so I can do a second query to find the true value.
Can someone point me in the right direction on finding the RowSource assuming I know the column name and then utilizing it to find the value Im after?
Edit: It seems that Im not explaining myself clearly, Here is a picture of what I trying to get programatically
Try this -- I think I finally understand why you are looking for the RowSource -- sorry I didn't "get" it at first. The field you're trying to pull is a foreign key into a description table.
This function should work as a general solution for all such fields (assuming the RowSource always has the primary key first, and the description second). If there is no RowSource, it will just pull the value of the field.
It's based on your original code, rather than the changes proposed by #ron, but it should set you in the right direction. You should fix it to make it parameterized, and allow for variant data types, as ron suggests (+1 ron)
As an aside, use the ampersand (&) to join strings together in VBA to avoid things like this: abc = "1" + 1, where abc is now equal to 2 instead of "11" as you would expect if both items were intended to be strings.
Public Function lookUpColumnValue(Database As Database, column As String, table As String, lookUpColumn As String, lookUpValue As String) As String
Dim sql As String
Dim recordSet As DAO.recordSet
Dim result As String
lookUpColumnValue = "" 'Return a blank string if no result
On Error Resume Next
sql = "SELECT [" & table & "].[" & column & "] FROM [" & table & "] WHERE [" & table & "].[" & lookUpColumn & "] = '" & lookUpValue & "'"
Set recordSet = Database.OpenRecordset(sql)
If Not recordSet.EOF Then
Dim td As DAO.TableDef
'this gives your number - say, 19
result = recordSet(column)
Set td = Database.TableDefs(table)
'Get the rowsource
Dim p As DAO.Property
For Each p In td.Fields(column).Properties
If p.Name = "RowSource" Then
RowSource = Replace(td.Fields(column).Properties("RowSource"), ";", "")
Exit For
End If
Next
If Not RowSource = "" Then
Dim rs2 As DAO.recordSet
Dim qd As DAO.QueryDef
Set qd = Database.CreateQueryDef("", RowSource)
Set rs2 = Database.OpenRecordset(RowSource)
If rs2.EOF Then Exit Function
PKField = rs2.Fields(0).Name
rs2.Close
qd.Close
sql = "SELECT * FROM (" & RowSource & ") WHERE [" & PKField & "]=[KeyField?]"
Set qd = Database.CreateQueryDef("", sql)
qd.Parameters("KeyField?").Value = result
Set rs2 = qd.OpenRecordset()
If Not rs2.EOF Then
'NOTE: This assumes your RowSource *always* has ID first, description 2nd. This should usually be the case.
lookUpColumnValue = rs2.Fields(1)
End If
Else
'Return the field value if there is no RowSource
lookUpColumnValue = recordSet.Fields(column)
End If
End If
End Function
If I understand your question correctly, I think using a parameter query will solve your problem. Using parameters is good practice since they will perform implicit data type casts and also prevent injection attacks.
Notice in the following function, I changed the lookupValue to a Variant type, which allows you to pass any type of value to the function.
Public Function lookUpColumnValue( _
database As DAO.database, _
column As String, _
table As String, _
lookUpColumn As String, _
lookUpValue As Variant) As String
Dim sql As String
Dim recordSet As DAO.recordSet
Dim result As String
Dim qd As QueryDef
Set qd = database.CreateQueryDef("")
sql = "SELECT [" + table + "].[" + column + "] FROM [" + table + "] " & _
"WHERE [" + table + "].[" + lookUpColumn + "] = [parm1];"
qd.sql = sql
qd.Parameters![parm1] = lookUpValue
Set recordSet = qd.OpenRecordset()
result = recordSet(column)
EDIT
lookUpColumnValue = DLookup("Space Use Description", "Space Use Codes", result)
End Function

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