This is an Excel to Access porting issue - Is it possible to convert an Excel VBA FIND method to work correctly in and with Access's VBA ?

chazrab · Feb 16, 2024

Excel's VBA FIND method easily finds multiple records and copies them to another sheet. However, for me, trying to use this same code to do the
same thing with Acess's VBA code and a table is a different story. I know there is a difference between a sheet and an Access db table. And I know
won't recognize some oof the following code lines
I'm sure there has to be many cases where an Excel sheet gets so large that it facilitates porting the Excel application to Access's database based application

Such is my case. The main data Sheet has 31.103 rows and Excel stops responding at times. This is unacceptable for me. It has to work right every time.
Please take a look at this FIND method. Granted, it's long, but I' d really appreciate somone's help in moving this to Access.
I am not having any luck with trying to do the same thing with an Access Query. (The SQL copy Query to Table solution causes multiple conflicts and seems inefficient)

Code:

CORRECT EXCEL VBA FIND CODE
Private Sub cmdFIND_Click()
Sheets("MAINARES2").UsedRange.ClearContents
Dim lastrow, lastrow2 As Integer, X As String, c As Range, rw As Long, firstAddress As Variant, rowno As Variant, RownoA As Variant
X = MAINWINDOW2.TextBox11.Value
With Worksheets("Sheet2").Range("E1:E31103")
Set c = .FIND(X, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
rw = 1
firstAddress = c.Address
Do
Worksheets("Sheet2").Select
c.Select
Range(Cells(c.Row, 2), Cells(c.Row, 7)).Copy Destination:=Sheets("MAINARES2").Range("B" & rw)
rw = rw + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
lastrow = Sheets("MAINARES2").Range("B" & rows.count).End(xlUp).Row
If lastrow = 1 Then
Range(Cells(c.Row + 7, 2), Cells(c.Row, 7)).Copy Destination:=Sheets("MAINARES2").Range("B" & rw)
Else
End If
Else
MsgBox "value not found"
End If
End With
rowno = Sheets("MAINARES2").Range("B2").End(xlDown).Row
Sheets("MAINARES2").Range("H1").Value = rowno 'total rows found in search
Sheets("MAINARES2").Range("I1").Value = X 'value to find, i.e.,, "last days"
End Sub

I apoligize for a lengthy post - I don't like them - but I cannot explain my dilemma and have people understand with less words and code.
If anyone with both Excel and Access  build experience could help me, I'd really appreciate it vey much.

cr

Trebor76 · Feb 25, 2024

Change any fields I have named "txtKJV" to simply "KJV" i.e. the field name in your table "tblTheBible".

When there is an error like that copy the contents of the strSQL variable into the SQL section of a blank query and run it to give more of an insight as to why it's failing.

Robert

Trebor76 · Feb 25, 2024

I've also just added Exit Sub near the top of the procedure to stop it if the initial value is not found as there's no need to continue and you may get the same message twice when the lngVerseID variable does not get set:

VBA Code:

strSQL = "SELECT * FROM [tblTheBible] WHERE INSTR([KJV],""" & Controls("txtSearchText").Value & """)>0;"
    Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL)
    If rs.EOF Then
        MsgBox """" & Me.Controls("txtSearchText").Value & """ was not found in the source table.", vbExclamation
        Exit Sub

chazrab · Feb 26, 2024

Hi Robert
I changed txtKJV to KJV everywhere and it does give the next 10 records below any verse I type in. But it displays them in a Msgbox, not in the txtMatchedVerses textbox on the form which is where the records are displayed. This code you wrote a while back does display records in the txtMatchedVerses textbox as we said it should, but only one verse is displayed for only one verse typed in txtSearchCriteria textbox.

Code:

Private Sub cmdTestCode_Click()
    Dim x As String
    Dim rs As Recordset
    Dim db As Database
    Dim strSQL As String
    Dim srchval As String
    x = Me.txtSearchCriteria.Value
    srchval = Me.txtSearchCriteria.Value
    With DoCmd
        .SetWarnings False
        .OpenQuery "qmakSearch" 'qmakSearch is a make table query that must exist on the Db
        .SetWarnings True
    End With
    If DCount("*", "tblSearchResults") > 0 Then 'tblSearchResults is the MakeTable created table from qmkSearch query
       Me.Controls("txtMatchedVerses").Value = "" 'Clear - Note txtMatchedVerses is the name of the text box thta must exist on the form to receive the results of the SQL query.
        strSQL = "SELECT * FROM tblSearchResults;"
        Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL)
        rs.MoveFirst
        Do Until rs.EOF
            Me.Controls("txtMatchedVerses").Value = IIf(Len(Me.Controls("txtMatchedVerses").Value) = 0, rs.Fields(0).Value, Me.Controls("txtMatchedVerses").Value & vbNewLine & vbNewLine & rs.Fields(0).Value)
            rs.MoveNext
        Loop
           Set rs = Nothing: Set db = Nothing
       MsgBox "There were " & DCount("*", "tblSearchResults") & " records found.", vbInformation
     Else
        MsgBox "There were no records found.", vbExclamation
    End If
    Me.Totrows = DCount("*", "tblSearchResults")
End Sub

Displaying the next 10 records when a verse is typed into txtSearchCriteria just needs to be adapted into this code. I tried doing that
myself and came up with errors, as you may have guessed. I tried to just put txtMatchVerses into where I thought it would go in your most recent
code, but in generated an error :

Code:

Private Sub Mt2415_Click()
    Dim strSQL As String, strVerseText As String
    Dim dicSearchText As Object
    Dim varItem As Variant
    Dim rs As Recordset
    Dim db As Database
    Dim lngVerseID As Long, i As Long, j As Long, k As Long
    strSQL = "SELECT * FROM [tblTheBible] WHERE INSTR([KJV],""" & Controls("txtSearchText").Value & """)>0;"
    Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL)
    If rs.EOF Then
        MsgBox """" & Me.Controls("txtSearchText").Value & """ was not found in the source table.", vbExclamation
    Else
        Set dicSearchText = CreateObject("Scripting.Dictionary")
        For Each varItem In Split(Controls("txtSearchText").Value, " ")
            i = i + 1
            dicSearchText.Add CStr(StrConv(varItem, vbLowerCase)), i
        Next varItem
        rs.MoveFirst
        Do Until rs.EOF
            For Each varItem In Split(rs.Fields("KJV"), " ")
                If IsNumeric(Left(varItem, 1)) = False Then
                varItem = AlphaOnly(CStr(varItem))
                End If
                If Not dicSearchText.Exists(CStr(StrConv(varItem, vbLowerCase))) = False Then
                    j = j + 1
                End If
            Next varItem
            If j = i Then
                lngVerseID = rs.Fields("ID")
                Exit Do
            End If
            j = 0
            rs.MoveNext
        Loop
        rs.Close
    End If
       If lngVerseID = 0 Then
        MsgBox """" & Me.Controls("[B]txtMatchedVerses[/B]").Value & """ was not found in the source table.", vbExclamation 'I put txtMatchedVerses between the [B] and [/B]
    Else
        strSQL = "SELECT * FROM [tblTheBible] WHERE ID >= " & lngVerseID & " AND ID <= " & lngVerseID + 10
        Set rs = db.OpenRecordset(strSQL)
        rs.MoveFirst
        Do Until rs.EOF
            k = k + 1
            strVerseText = IIf(Len(strVerseText) = 0, k & " " & rs.Fields("KJV"), strVerseText & vbNewLine & vbNewLine & k & " " & rs.Fields("KJV"))
            rs.MoveNext
        Loop
        MsgBox strVerseText
            rs.MoveNext '--->Error "No current record"
    End If
    Set rs = Nothing: Set db = Nothing
End Sub

Trebor76 · Feb 26, 2024

Hi Charles,

Here are both produces again with all the changes which works for me:

VBA Code:

Option Compare Database
Option Explicit
Private Sub cmdSearch_Click()

    Dim strSQL As String, strVerseText As String
    Dim dicSearchText As Object
    Dim varItem As Variant
    Dim rs As Recordset
    Dim db As Database
    Dim lngVerseID As Long, i As Long, j As Long, k As Long
   
    strSQL = "SELECT * FROM [tblTheBible] WHERE INSTR([KJV],""" & Controls("txtSearchText").Value & """)>0;"
    Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL)
    If rs.EOF Then
        MsgBox """" & Me.Controls("txtSearchText").Value & """ was not found in the source table.", vbExclamation
        Exit Sub
    Else
        Set dicSearchText = CreateObject("Scripting.Dictionary")
        For Each varItem In Split(Controls("txtSearchText").Value, " ")
            i = i + 1
            dicSearchText.Add CStr(StrConv(varItem, vbLowerCase)), i
        Next varItem
        rs.MoveFirst
        Do Until rs.EOF
            For Each varItem In Split(rs.Fields("KJV"), " ")
                If IsNumeric(Left(varItem, 1)) = False Then
                    varItem = AlphaOnly(CStr(varItem))
                End If
                If Not dicSearchText.Exists(CStr(StrConv(varItem, vbLowerCase))) = False Then
                    j = j + 1
                End If
            Next varItem
            If j = i Then
                lngVerseID = rs.Fields("ID")
                Exit Do
            End If
            j = 0
            rs.MoveNext
        Loop
        rs.Close
    End If
   
    If lngVerseID = 0 Then
        MsgBox """" & Me.Controls("txtSearchText").Value & """ was not found in the source table.", vbExclamation
    Else
        strSQL = "SELECT * FROM [tblTheBible] WHERE ID >= " & lngVerseID & " AND ID <= " & lngVerseID + 10
        Set rs = db.OpenRecordset(strSQL)
        rs.MoveFirst
        Do Until rs.EOF
            k = k + 1
            strVerseText = IIf(Len(strVerseText) = 0, k & " " & rs.Fields("KJV"), strVerseText & vbNewLine & k & " " & rs.Fields("KJV"))
            rs.MoveNext
        Loop
        txtMatchedVerses = strVerseText 'Populate 'txtMatchedVerses' textbox
    End If
   
    Set rs = Nothing: Set db = Nothing

End Sub
Function AlphaOnly(strSource As String) As String
  
    Dim objRegExpr As Object
  
    Set objRegExpr = CreateObject("vbscript.regexp")

    With objRegExpr
        .Pattern = "[^a-zA-Z\s]+" 'Remove anything that is not a-z, A-Z or a space
        .Global = True
        .IgnoreCase = True
        .MultiLine = True
    End With

    AlphaOnly = objRegExpr.Replace(strSource, "")
   
End Function

Regards,

Robert

chazrab · Feb 26, 2024

Hi Robert. I'll have a look later. All of a sudden, I was changing code lines in the Load event, the 'Not responding...' came up, screen turned white. I had to go to Task Manager to close the app (little circle kept going round and round too long) I've looked everywhere - onedrive and the C drive on this machine and I cannot find the latest version which I named BIBLE APPLICATION.2.26.24 anywhere. Looking for the last hour.
I saved backups when prompted but I cannot find where they are stored. That file can't just disappear. It has to be somewhere. I would know if I accidentally deleted it because that involves a specific action which I did not do.

I'm trying not to let this get to me.
To be continued...hopefully.
cr

chazrab · Feb 26, 2024

...I found the file. Somewhere in this code is crashing the app. It worked early this AM. All this does is open the form with the textboxes populated
with records from tblSearchResults and mytbllSearchResults of the previous search:

Code:

Private Sub Form_Load()
Me.txtSearchCriteria = gSavedValue
Dim cnt, cnt2 As Long
 If DCount("*", "tblSearchResults") > 0 Then
        strSQL = "SELECT * FROM tblSearchResults;"
        Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL)
        rs.MoveFirst
        Do Until rs.EOF
            Me.Controls("txtMatchedVerses").Value = IIf(Len(Me.Controls("txtMatchedVerses").Value) = 0, rs.Fields(0).Value, Me.Controls("txtMatchedVerses").Value & vbNewLine & vbNewLine & rs.Fields(0).Value)
            rs.MoveNext
        Loop
        Set rs = Nothing: Set db = Nothing
    Else
    End If
cnt = DCount("*", "tblSearchResults")
Me.Totrows.Value = cnt
Me.totrows2.Value = cnt2


    Dim rs2 As Recordset
    Dim db2 As Database
    Dim strSQ2L As String
    With DoCmd
        .SetWarnings False
        .OpenQuery "txtbx2q"
        .SetWarnings True
    End With
    If DCount("*", "mytblSearchResults") > 0 Then
       Me.Controls("Textbox2").Value = ""
        strSQL = "SELECT * FROM maktxtbx2tbl;"
        Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL)
        rs.MoveFirst
        Do Until rs.EOF
            Me.Controls("Textbox2").Value = IIf(Len(Me.Controls("Textbox2").Value) = 0, rs.Fields(1).Value, Me.Controls("Textbox2").Value & vbNewLine & vbNewLine & rs.Fields(1).Value)
            rs.MoveNext
        Loop
        Set rs = Nothing: Set db = Nothing
        MsgBox "There were " & DCount("*", "maktxtbx2tbl") & " records found.", vbInformation
    Else
        MsgBox "There were no records found.", vbExclamation
    End If
 Me.totrows2 = DCount("*", "maktxtbx2tbl")
End Sub

cr

Trebor76 · Feb 26, 2024

See if compiling the code raises any issues:

Open the Visual Basic Editor (i.e. where you enter and edit the code)
From the menu select Debug then Compile

There maybe variables that are not defined as I use Option Explicit (if there are - define them) or sometimes just compiling the code resolves the issue.

chazrab · Feb 26, 2024

Hi Robert - it works!. I know that's no big deal for you, but it's a giant leap for me in the progress of what I want this app to do
I just have to use that code as a template for Textbox2 and its associated versetxt2 field and any other textboxes I want to have
this capability with.

I have work to do on my end, so I'll be back with you later on my progress.

Thanks for taking the time for helping me with this app.

cr

Trebor76 · Feb 26, 2024

Hi Robert - it works!

Great news

If there are any more questions I really think you should post them in the Access section of the forum with a link back to this thread if you think it will help as you may get more support and it may help others if they are have similar Access issues. I'll keep an eye out as well.

Regards,

Robert

chazrab · Feb 26, 2024

Will do. I assume you mean this link from the address bar above: