Access VBA help

[acces]

Hi,


I am currently making a search loop in VBA for my database. In this database i Have 2 Tables, one with the customers records called "customersT" and another one with search words called "swordsT". The idea is to use a filter to filter out the customers that match any of the searchwords in the "swordsT" table. Any customer that does not match any of the search words gets added to another table called "filteredCustomerT".

For example:

table "customersT"
Field "mailFi"
mike@coolmail.com
john@hotmail.com


dave@mail.com
jonny@mailx.com

table "swordsT"
Field "wordFi"
hotmail
jonny

table "filteredCustomerT"
Field "filteredmailFi"
mike@coolmail.com
dave@mail.com

So if i run this VBA code i want john@hotmail.com and jonny@mailx.com to be filtered out. The "customerT" table contains 200k records and the "swordsT" table contains 2k search words. I have made a VBA code that should loop through the "customerT" table. For every record in the "customerT" table a have another nested loop that loops through the "swordsT" table so see if there is any match. If there is not a match the VBA code copies the entry to anther table called "filteredCustomerT". I Use the instr function to do the matching.

Below i have posted the VBA code that does not seem to work. Can anyone help me and maybe point out a fault in the code. I am very new to VBA programming.

Option Compare DatabaseOption Explicit


Sub filter()


Dim customerMail As Recordset
Dim SearchwordWord As Recordset
Dim mailFilteredCustomerT As Recordset
Dim customerTemp As String
Dim srcwTemp As String


Set customerMail = CurrentDb.OpenRecordset("customerT")
Set SearchwordWord = CurrentDb.OpenRecordset("swordsT")
Set mailFilteredCustomerT = CurrentDb.OpenRecordset(""filteredCustomerT"")


Do Until customerMail.EOF    
    Do Until SearchwordWord.EOF
        customerTemp = customerMail![mailFi]
        srcwTemp = SearchwordWord![wordFi]


        If (InStr(customerTemp, srcwTemp) = 0) Then
            mailFilteredCustomerT.AddNew
            mailFilteredCustomerT![filteredmailFi] = customerTemp
            mailFilteredCustomerT.Update
            Exit Do


        End If


        SearchwordWord.MoveNext
    Loop


    customerMail.MoveNext    
Loop
End Sub

The result i get is that just the first mail in the "customerT" table gets copied in 2000 different entries in the "filteredCustomerT" table. I would be very grateful if someone could spot some faults in the code that may cause it not to work.

Have a nice day!

BR
acces

[June7]

What is sparrSokord? What is mainTemp?

Step debug. Refer to link at bottom of my post for debugging guidelines.

customerTemp = customerMail![MailFi] should be in the outer loop.

Is looping swordsT really necessary? Seems to me there can be only one match. At least open filtered SearchwordWord recordset. Put the Set statement at start of first loop and close the recordset at end of first loop.
Set SearchwordWord = CurrentDb.OpenRecordset("SELECT wordFi FROM swordsT WHERE wordFi='" & customerTemp & "';")
If SearchwordWord.RecordCount = 0 Then

Or maybe use DLookup() or DCount().
If DCount("*", "swordsT", "InStr('" & customerTemp & "', [wordFi]) > 0") = 0 Then

Why are you using code to write records to another table and not just building a query that joins tables and apply filter criteria? This would be a Find Unmatched query. There is a wizard for that.

Review http://allenbrowne.com/ser-29.html#Move_With_No_Records

[acces]

Hi Thanks for your reply!

sparrSokord and mainTemp should have been SearchwordWord and customerTemp. I have updated that in the code i posted above now.


DLookup() should be an easier solution. I will look into DCount as well.

The problem with the Unmatched Query is that it has to be exact matches to work? For example the word "mike" would not trigger a match with "mike@mail.com"? but i can be wrong.

If there is any Query setting to do this i have pretty much wasted a whole week trying to solve this problem haha. First i learned Access SQL to try to achieve this function just to find out that it could not solve the problem. After that i tried to learn VBA and came up with the code above. I have some programing knowledge since before but this has still been quite time-consuming .

[June7]

Consider:

SELECT customerT.* FROM customerT, swordsT WHERE NOT mailFi LIKE "*" & wordFi & "*";

[acces]

Ok should it not be?:

SELECT mailFi.* FROM customerT, swordsT WHERE NOT mailFi LIKE "*" & wordFi & "*";

[June7]

mailFI is the field, not table. Table name would be prefix for .*. Did you try the query?

[acces]

Yes i did, It did not work it just took the first record from the customerT and copied it in the whole table. But i have updated the VBA code and it works now. The only problem is that just does 40k of the 200k records and then crashes. But it removes all the entries that include the search word.

I have attached that code below.

But it has not the same name as before.

The main table is called "Main" and the field is called "Mail". And the serchword table is called "Sparr" with "sparrord" as its field. And it moves the new entries to "Testtable" with the field "testMail"

Main - Mail
Sparr - sparrord
Testtable - testMail

Option Compare Database
Option Explicit


Sub filter()


Dim mainMail As Recordset
Dim sparrSokord As Recordset
Dim testtableTestmail As Recordset
Dim mainTemp As String
Dim sparrTemp As String
Dim match As Integer


Set mainMail = CurrentDb.OpenRecordset("Main")
Set sparrSokord = CurrentDb.OpenRecordset("Sparr")
Set testtableTestmail = CurrentDb.OpenRecordset("Testtable")


Do Until mainMail.EOF
        
        mainTemp = mainMail![Mail]
        match = 0
        sparrSokord.MoveFirst
        Do Until sparrSokord.EOF
            sparrTemp = sparrSokord![sparrord]
        
            If (InStr(mainTemp, sparrTemp) <> 0) Then
                match = 1
                Exit Do
            End If
           
        
            sparrSokord.MoveNext
        Loop
        
        If (match = 0) Then
            testtableTestmail.AddNew
            testtableTestmail![testMail] = mainTemp
            testtableTestmail.Update
        End If
    
mainMail.MoveNext


Loop
       


End Sub

[June7]

The query is not for use in VBA. It is suggested as a stand alone query object.

I corrected DCount code in post 2.

[acces]

Yes i opened a new Query and copied the code in the SQL view. Have i done it wrong?

[June7]

What happened? Post the sql statement you used with your correct field and table names.

[acces]

This was the SQL statement i used.

SELECT Main.* FROM Main, Sparr WHERE NOT Mail LIKE "*" & sparrord & "*";

And the result was 200k entries that with the same data as the first entry in Main.

[ssanfu]

I looked at your code and made a few changes...
"Filter" and "Match" are reserved words in Access/Jet, so I changed them. Also, some of your variables were long - I shortened them.

Sub FilterWords()
    Dim d As DAO.Database
    
    Dim mm As DAO.Recordset    'mainMail
    Dim ss As DAO.Recordset    'sparrSokord
    Dim tt As DAO.Recordset    'testtableTestmail
    
    Dim mainTemp As String
    Dim sparrTemp As String
    
    Dim IsMatch As Boolean

    Set d = CurrentDb

    Set mm = d.OpenRecordset("Main")
    If mm.BOF And mm.EOF Then
        msgbox "No records found for 'Main' "
        mm.Close
        Exit Sub
    End If
    mm.MoveLast
    mm.MoveFirst

    Set ss = d.OpenRecordset("Sparr")
    If ss.BOF And ss.EOF Then
        msgbox "No records found for 'Sparr' "
        ss.Close
        Exit Sub
    End If
    ss.MoveLast
    ss.MoveFirst

    'deletes all records from table
    'comment out the following line if you do not want to delete all records
    ' "Testtable" before running this code.
    d.Execute "DELETE * FROM Testtable"


    Set tt = d.OpenRecordset("Testtable")

    'start of outer loop
    Do Until mm.EOF

        mainTemp = mm!Mail
        IsMatch = False
        'move inner loop to top of recordset
        ss.MoveFirst

        'start of inner loop
        Do Until ss.EOF
            sparrTemp = ss!sparrord

            If (InStr(mainTemp, sparrTemp) <> 0) Then
                IsMatch = True
                Exit Do
            End If

            ss.MoveNext
        Loop

        'if not found, add to test table
        If (IsMatch = False) Then
            tt.AddNew
            tt!testMail = mainTemp
            tt.Update
        End If

        'move outer loop to next record
        mm.MoveNext

    Loop

    'clean up
    On Error Resume Next

    'close recordsets
    mm.Close
    ss.Close
    tt.Close

    'destroy objects
    Set d = Nothing
    Set mm = Nothing
    Set ss = Nothing
    Set tt = Nothing

End Sub

I don't see anything wrong with the code... let me know what happens.

[acces]

I closed some programs and other process on there computer, tried your version and it worked just fine, thank you so much!

It is nice to finally put an end to this

But my access is a still bit slow is there anyway too speed it up? Some times manual searches in the big table with 200k records goes super fast and sometimes it is really slow.

Thanks also for the improvements, the delete feature makes things a lot easier!

Should i mark this thread as solved now? this is my first time on this forum

[ssanfu]

Happy it is working.......

But my access is a still bit slow is there anyway too speed it up?

It depends on processor (single core, dual core,quad core), processor speed, amount of RAM, hard drive speed (5600 RPM vs 7200 RPM), number of other applications active, etc.

So fast processor, lots of RAM (8GB), only Access running = faster.

Queries would/should be faster. Could do like June suggested and use an unmatched query. I don't have your dB so I can't help there.


Last weekend I wrote code (looping) to process 83,000+ records. I let it run 36 hours .... it had only processed 5300+ records. The problem was that after doing some calculations (this is fast) the code had to search about 2 million records to do the update of a field.
Then I re-wrote the code and the number of records went up to approx 375,000. The processing time went down to 5 hrs and 20 minutes. Light speed better!!.
(I have a 2.3GHz dual code with 4 GB of RAM. Only Access was running)

If you want to post you dB, I'll take a look at it over the weekend.
Change sensitive data ; maybe 100 records in the main table and 10 in the word search table.
Compact & Repair, then ZIP it.

Should i mark this thread as solved now?

If your question (looping) has been answered, then yes. The question about speeding the process probably should be a new thread.

[acces]

Ok, regarding the speed is not that big of a problem for us, i was just curious if there was some common performance settings. Would it be possible to use SQL code in a query to achieve the same function as the VBA code in this thread?