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
Related
I'm trying to use the seek method within a VBA code nested loop. The goal is to use a query to search a table for ID values that match what was identified in the first loop. I'm returning 'Method or data member not found' The error is occurring on the line 'Set StrSQL2.Index = "ID"'. Since "ID" is the only column in that table created by the query I tried commenting it out, but it only shifts the error down to the next line 'StrSQL2.Seek "=", !external_nmad_id
Public Sub EditFinalOutput2()
'set variables
Dim i As Long
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim StrSQL2 As DAO.QueryDef
Dim IRSfileFormatKey As String
Dim external_nmad_id As String
Dim nmad_address_1 As String
Dim nmad_address_2 As String
Dim nmad_address_3 As String
Dim mytestwrite As String
'open reference set
Set db = CurrentDb
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest")
'Set ss = db.OpenRecordset("1042s_FinalOutput_7")
'Set StrSQL1 = db.OpenRecordset("SELECT RIGHT(IRSfileFormatKey, 10) As ID
FROM 1042s_FinalOutput_7;")
With qs.Fields
intCount = qs.RecordCount - 1
For i = 0 To intCount
If (IsNull(!nmad_address_1) Or (!nmad_address_1 = !nmad_city) Or (!nmad_address_1 = !Webir_Country) And IsNull(!nmad_address_2) Or (!nmad_address_2 = !nmad_city) Or (!nmad_address_2 = !Webir_Country) And IsNull(!nmad_address_3) Or (!nmad_address_3 = !nmad_city) Or (!nmad_address_3 = !Webir_Country)) Then
DoCmd.RunSQL "INSERT INTO Addresses_ToBeReviewed SELECT SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE (((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id & "'));"
Else:
Set StrSQL2 = CurrentDb.CreateQueryDef("", "SELECT RIGHT(IRSfileFormatKey, 10) As ID FROM 1042s_FinalOutput_7;")
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
Set StrSQL2.Index = "ID"
StrSQL2.Seek "=", !external_nmad_id
If ss.NoMatch Then
DoCmd.RunSQL "INSERT INTO Addresses_NotUsed SELECT SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE (((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id & "'));"
Else: Set ss = db.OpenRecordset("1042s_FinalOutput_7")
ss.Edit
ss.Fields("box13c_Address") = qs.Fields("nmad_address_1") & qs.Fields("nmad_address_2") & qs.Fields("nmad_address_3")
ss.Update
End If
End If
qs.MoveNext
Next i
End With
'close reference set
qs.Close
Set qs = Nothing
ss.Close
Set ss = Nothing
End Sub
Consider a stripped down version of your code which still recreates the problem you're trying to solve.
Dim StrSQL2 As DAO.QueryDef
Set StrSQL2 = CurrentDb.CreateQueryDef("", "SELECT RIGHT(IRSfileFormatKey, 10) As ID FROM 1042s_FinalOutput_7;")
Set StrSQL2.Index = "ID"
When you attempt to run that code, Access will complain "Object doesn't support this property or method". The reason that happens is because StrSQL2 is a DAO.QueryDef and a QueryDef does not have an Index property. See QueryDef Members (DAO)
So then you disable that problem line and try this ...
StrSQL2.Seek "=", 27 'I substituted an arbitrary number for !external_nmad_id just to keep this simple '
But Access responds with the same complaint again, which is because a QueryDef does not have a Seek method.
Both Index and Seek are object members of a DAO.Recordset, so use them with a Recordset instead of a QueryDef
And if you go that route, designate the name of your controlling index like this ...
YourRecorsetVariable.Index = "ID"
Don't use Set there and make sure that "ID" is the name of the index ... which is not necessarily the name of the column which is indexed.
I'm attempting to write a loop in VBA for Access 2010, where the loop looks through a table (table: "SunstarAccountsInWebir_SarahTest") and evaluates a number of conditions, and depending on the condition - may then loop through a different table ("1042s_FinalOutput_7") to see if it has an ID that matches. If it does match, it inserts "Test" into a field, if not - it should export that row of values (from the first loop - out of "SunstarAccountsInWebir_SarahTest") into an excel file.
My issue is that my code is exporting the entirety of the table "SunstarAccountsInWebir_SarahTest", I only want it to export the row corresponding to the value of i in the loop. How can I amend my code to do this?
Public Sub EditFinalOutput2()
'set loop variables
Dim i As Long
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim strSQL As String
Dim external_nmad_id As String
Dim IRSfileFormatKey As String
'Function GetID(external_nmad_id As String, IRSfileFormatKey As String)
'open reference set
Set db = CurrentDb
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest")
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
'set loop for whole recordset(this is the original location, will try putting it within the If, ElseIf loop)
'For i = 0 To qs.RecordCount - 1
With qs.Fields
For i = 0 To qs.RecordCount - 1
If (IsNull(!nmad_address_1) Or (!nmad_address_1 = !nmad_city) Or (!nmad_address_1 = !Webir_Country) And IsNull(!nmad_address_2) Or (!nmad_address_2 = !nmad_city) Or (!nmad_address_2 = !Webir_Country) And IsNull(!nmad_address_3) Or (!nmad_address_3 = !nmad_city) Or (!nmad_address_3 = !Webir_Country)) Then
MsgBox "This was an invalid address"
Else:
With ss.Fields
For j = 0 To ss.RecordCount - 1
If (qs.Fields("external_nmad_id") = Right(ss.Fields("IRSfileFormatKey"), 10)) Then
ss.Edit
ss.Fields("box13_Address") = "Test"
ss.Update
Else: DoCmd.TransferSpreadsheet acExport, 10, "SunstarAccountsInWebir_SarahTest", "\\DTCHYB-MNMH001\C_WBGCTS_Users\U658984\My Documents\pre processor\PreProcessor7\ToBeReviewed\AddressesNotActiveThisYear.xlsx", False
End If
ss.MoveNext
Next j
End With
End If
qs.MoveNext
Next i
End With
'close reference set
qs.Close
Set qs = Nothing
ss.Close
Set ss = Nothing
End Sub
This ended up being the closest. I needed to switch to a "Do While" loop rather than a second integer loop. The code for so is below:Public Sub EditFinalOutput2()
'set variables
Dim i As Long
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim strSQL As String
Dim external_nmad_id As String
Dim IRSfileFormatKey As String
Dim mytestwrite As String
mytestwrite = "No"
'open reference set
Set db = CurrentDb
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest")
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
With qs.Fields
For i = 0 To qs.RecordCount - 1
If (IsNull(!nmad_address_1) Or (!nmad_address_1 = !nmad_city) Or
(!nmad_address_1 = !Webir_Country) And IsNull(!nmad_address_2) Or (!nmad_address_2 =
!nmad_city) Or (!nmad_address_2 = !Webir_Country) And IsNull(!nmad_address_3) Or
(!nmad_address_3 = !nmad_city) Or (!nmad_address_3 = !Webir_Country)) Then
DoCmd.RunSQL "INSERT INTO Addresses_ToBeReviewed SELECT
SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE
(((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id &
"'));"
Else:
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
With ss.Fields
'if not invalid address, loop through second (final output) table to find
matching ID's
If ss.EOF = False Then
ss.MoveFirst
Do
Dim mykey As String
mykey = Right(ss!IRSfileFormatKey, 10)
Debug.Print mykey
If qs.Fields("external_nmad_id") = mykey Then
ss.Edit
ss.Fields("box13c_Address") = qs.Fields("nmad_address_1") &
qs.Fields("nmad_address_2") & qs.Fields("nmad_address_3")
ss.Update
mytestwrite = "Yes"
End If
ss.MoveNext
'if the valid address doesn't match to final output table, add to list of
addresses not matched
Loop Until ss.EOF
If mytestwrite = "No" Then
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO Addresses_NotUsed SELECT
SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE
(((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id &
"'));"
DoCmd.SetWarnings True
End If
End If
End With
End If
qs.MoveNext
Next i
End With
'close reference set
qs.Close
Set qs = Nothing
ss.Close
Set ss = Nothing
End Sub
Ok, based on your stated goal, there are a few errors in your approach.
Here is how I understand your goal based on your opening paragraph:
Loop through each record in table TableA. If the record meets
certain complex criteria, search a second table TableB to see if any
records in TableB contain a matching ID value from this record in
TableA. If a match exists, update a field in TableB, otherwise, export the record from TableA to Excel.
I will describe how the code you have presented is processing your data, and then I will explain how I would approach this problem.
First, as #ScottHoltzman alluded, the DoCmd.TransferSpreadsheet statement that you have in your code will, of course, transfer the entire table to Excel because that is what you told it to do. The 3rd parameter specifies the data to be exported, and you gave it the full table name, so the full table will be exported.
Second, I think you are misunderstanding how looping through the two RecordSets in your code is actually functioning. Your code is doing the following:
Evaluate a record in qs. If it doesn't meet the criteria, move to the next qs record and repeat step 1.
If the record in qs does meet the criteria, evaluate a record in ss against this record in qs.
If they match, update ss and move to the next ss record, go to step 2, remembering that qs is still pointing at the same record and has not moved.
If they do not match, transfer the entire table to Excel, now move to the next ss record, go to step 2, again remembering that qs is still pointing at the same record and has not moved.
Once all records in ss have been processed through steps 2, 3 & 4, move to the next qs record and go to step 1
I would expect your code to export the table to Excel over and over again many times.
I would also expect your code to get an error as soon as you begin to process the 2nd qs record that moves on to step 2 because after having processed steps 2, 3 & 4 for the first qs record that met your criteria, the ss RecordSet will be pointing at EOF, and you don't have any code to move the pointer back to the first record in ss.
Anyway, since you have a complex criteria for determining if a record is exported or not, I would recommend adding a single True/False field to TableA called ToExport. Now, at the beginning of your code, you would set ToExport = False for all records in TableA. Then, your code would work to evaluate each record in TableA to determine if the record should be exported. If it should, you update ToExport to be True. Once you have looped through the entire table, only the records needing exported will be marked as ToExport = True. Now, you export just the True records to Excel, thereby achieving your desired result.
Here is some code that should achieve this goal in an efficient manner. This code tries to use the tables and criteria from your original source. It also replaces your With blocks and For loops with more useful Do loops, taking advantage of built-in RecordSet looping and EOF checking.
Public Sub EditFinalOutput2()
Dim db As DAO.Database
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb()
strSQL = "UPDATE [SunstarAccountsInWebir_SarahTest] SET ToExport = False;"
db.Execute strSQL
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest", dbOpenDynaset)
Do While Not qs.EOF
If (IsNull(qs("nmad_address_1")) Or (qs("nmad_address_1") = qs("nmad_city")) Or (qs("nmad_address_1") = qs("Webir_Country")) And IsNull(qs("nmad_address_2")) Or (qs("nmad_address_2") = qs("nmad_city")) Or (qs("nmad_address_2") = qs("Webir_Country")) And IsNull(qs("nmad_address_3")) Or (qs("nmad_address_3") = qs("nmad_city")) Or (qs("nmad_address_3") = qs("Webir_Country"))) Then
MsgBox "This was an invalid address"
Else
strSQL = "SELECT * FROM [1042s_FinalOutput_7] WHERE Right([IRSfileFormatKey], 10) = """ & qs("external_nmad_id") & """;"
Set ss = db.OpenRecordset(strSQL, dbOpenDynaset)
If ss.BOF Then
qs.Edit
qs("ToExport") = True
qs.Update
Else
Do While Not ss.EOF
ss.Edit
ss("box13_Address") = "Test"
ss.Update
ss.MoveNext
Loop
End If
ss.Close
End If
qs.MoveNext
Loop
qs.Close
strSQL = "SELECT * FROM [SunstarAccountsInWebir_SarahTest] WHERE ToExport = True;"
DoCmd.TransferSpreadsheet acExport, 10, strSQL, "\\DTCHYB-MNMH001\C_WBGCTS_Users\U658984\My Documents\pre processor\PreProcessor7\ToBeReviewed\AddressesNotActiveThisYear.xlsx", False
Set qs = Nothing
Set ss = Nothing
db.Close
Set db = Nothing
End Sub
I hope this helps you better achieve your goal.
Create a query like this, and execute it, and return dim rst as Recordset
NOTE: I have changed the AND-s to OR-s as that is what I think you want...
Select qs.*
From
(Select *
From SunstarAccountsInWebir_SarahTest
Where Not
(
(IsNull(nmad_address_1)
Or (nmad_address_1 = nmad_city)
Or (nmad_address_1 = Webir_Country)
OR IsNull(nmad_address_2)
Or (nmad_address_2 = nmad_city)
Or (nmad_address_2 = Webir_Country)
OR IsNull(nmad_address_3)
Or (nmad_address_3 = nmad_city)
Or (nmad_address_3 = Webir_Country)
)
) as qs
Left Join
(Select *
,Right(ss.Fields("IRSfileFormatKey"), 10) as ssKey
From 1042s_FinalOutput_7
) as ss
On qs.external_nmad_id = ss.ssKey
Where ssKey is NULL
Then output the rst --(taken from https://support.microsoft.com/en-us/help/246335/how-to-transfer-data-from-an-ado-recordset-to-excel-with-automation )
' Copy field names to the first row of the worksheet
fldCount = rst.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
Next
' Copy the recordset to the worksheet, starting in cell A2
xlWs.Cells(2, 1).CopyFromRecordset rst
'Note: CopyFromRecordset will fail if the recordset
'contains an OLE object field or array data such
'as hierarchical recordsets
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.
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
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