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]

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)

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]

I'm a little lost. Why would Matthew 24:15 return nine matches? Surely it should only return that verse i.e. one match?

 

[chazrab]

It does only return one match. What I was trying to explain is that the txtMatched Verses large textbox does display that verse - but only that one verse.
Which is the way we told the code to do it. What I am saying is how do we tell Access in code to display that verse + the 8 rows afterwards (below ) Matthew 24:15? I did this very easily in Excel as shown in the code below. To understand the meaning of any one word, verse or phrase in the Bible that verse or word has to be read in its entire context - meaning all the verses below and/or above it. I only want the 8 or so verses that folloe.

In trying to figure this out on my own, chatGPT gave me this as an answer:

Sub CopyMatthewVerses()
Dim rs As Recordset
Dim strSQL As String
Dim i As Integer
Dim verseText As String
' Define your table name
Const tableName As String = "Table1"
' Define the starting verse (Matthew 24:15)
strSQL = "SELECT * FROM Sheet2 WHERE Verse = 'Matthew 24:15'"
Set rs = CurrentDb.OpenRecordset(strSQL)
' Check if the record exists
If Not rs.EOF Then
' Get the verse text
verseText = rs("VerseText")
'HERE'S THE FOR LOOP CODE THAT SHOULD DISPLAY THE NEXT 10 VERSES:
' Loop through the next 10 verses
For i = 1 To 10
rs.MoveNext
If Not rs.EOF Then
verseText = verseText & vbCrLf & rs("VerseText")
Else
Exit For
End If
Next i
' Insert the concatenated verses into your new table
CurrentDb.Execute "INSERT INTO " & Table1 & " (VerseText) VALUES ('" & Replace(verseText, "'", "''") & "')"
Else
MsgBox "Matthew 24:15 not found in the source table."
End If
rs.Close
Set rs = Nothing
End Sub

With this code, the new table I created, Table1, gave only Matthew 24:15 when it should have had Matthew 24:15 + the 10 verses below
that in the table. Then that table could be used to populate txtMatchedverses. It would be tblVerseResults in the original table being copied to. Table1 was just a new table to experiment with this.




The way I did this in Excel:

Private Sub ListBox1_Click()
Dim n As Long
n = ListBox1.ListIndex
Me.TextBox1.Value = ListBox1.List(n, 3) _
& vbCrLf _
& ListBox1.List(n + 1, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 2, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 3, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 4, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 5, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 6, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 7, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 8, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 9, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 10, 3) _
& vbCrLf _
& vbCrLf + ListBox1.List(n + 11, 3) _
& vbCrLf _

Sorry for the confusion. When you get a chance. It seems to me, all that needs to be done is to add that For loop code to the current button code
you did which looks like this now and displays only Matthew 24:15 or any one verse:

Private Sub cmdTestCode_Click()
    Dim rs As Recordset
    Dim db As Database
    Dim strSQL As String
    Dim srchval As String
    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 & 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

Robert, thanks again for all your help and sticking with me on this. As mentioned, I'm trying to take as much of this development
effort off of you and do it myself. Hopefully, I've explained the confusion.

cr

 

[Trebor76]

This SQL statement will only return one match (record)...

strSQL = "SELECT * FROM Sheet2 WHERE Verse = 'Matthew 24:15'"

...so you can't increment ten more records from it.

You need to grab the verse ID (23,973 in this case) and then do another SQL statement based on that for the next ten verses like so:

Private Sub cmdTestCode_Click()

    Dim strSQL As String, strVerseText As String
    Dim rs As Recordset
    Dim db As Database
    Dim lngVerseID As Long, i As Long
   
    strSQL = "SELECT lngID FROM tblBibleBooks WHERE [txtVerseHeader] = '" & Me.Controls("txtWordSearch").Value & "';"
    Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL)
    If rs.EOF Then
        MsgBox """" & Me.Controls("txtWordSearch").Value & """ was not found in the source table.", vbExclamation
    Else
        lngVerseID = rs.Fields(0)
        rs.Close
        strSQL = "SELECT [txtVerseText_KJV], [txtVerseHeader] FROM tblBibleBooks WHERE lngID >= " & lngVerseID & " AND lngID <= " & lngVerseID + 10 & ";"
        Set rs = db.OpenRecordset(strSQL)
        rs.MoveFirst
        Do Until rs.EOF
            i = i + 1
            strVerseText = IIf(Len(strVerseText) = 0, i & " """ & rs.Fields(0) & """ " & rs.Fields(1), strVerseText & vbNewLine & i & " """ & rs.Fields(0) & """ " & rs.Fields(1))
            rs.MoveNext
        Loop
    End If
    
    Set rs = Nothing: Set db = Nothing
    
    MsgBox strVerseText

End Sub

It's getting a little hard to offer advice as I'd need to see to how you've structured the main table and if you have any other table(s) linked to it as I would do for a summary of each of the 66 books. Your field names would obviously be different to mine too.

It's late here in AUS so I'll sign off now and have another look tomorrow if you've posted back with any other issue(s).

Robert

 

[chazrab]

Error in code at this line:

strSQL = "SELECT lngID FROM tblBibleBooks WHERE [txtVerseHeader] = '" & Me.Controls("txtWordSearch").Value & "';"

 

[chazrab]

No other tables linked to the main table(the source table where the search is done).

 

[Trebor76]

It's getting a little hard to offer advice as I'd need to see to how you've structured the main table and if you have any other table(s) linked to it as I would do for a summary of each of the 66 books. Your field names would obviously be different to mine too.

I've structured my main table different to you (refer attached). Like in Excel I think it's a good idea to keep data separate and then join it you need to as the SQL statement that is failing for you (works for me) is doing. Based on your field names try the following (you will have change the name of the textbox (I used "txtSearchText") on your form that captures the user's search text):

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([txtKJV],""" & 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("txtKJV"), " ")
                varItem = AlphaOnly(CStr(varItem))
                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]txtSearchText[/B]").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("txtKJV"), strVerseText & vbNewLine & k & " " & rs.Fields("txtKJV"))
            rs.MoveNext
        Loop
        MsgBox strVerseText
    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, "")

    Set objRegExpr = Nothing
   
End Function

You should also start a new thread in the Microsoft Access section of the forum with a link back to this thread as these are not Excel questions and you'll probably get more hits.

Regards,

Robert

 

[Trebor76]

So the code can find verses as part of the entered search criteria, replace this line...

varItem = AlphaOnly(CStr(varItem))

...with these:

If IsNumeric(Left(varItem, 1)) = False Then
varItem = AlphaOnly(CStr(varItem))
End If

 

[chazrab]

HI Robert - having a rough go of it. Made changes to the code as above. Getting "Sub or Function not defined"error at line
indicated in images below. If it gave desired results for you it should for me.
I created a new textbox on the form named txtSearchText, as directed, copied this code below to a button
typed in "Daniel 8", then error. Tried again with the term "latter days", again same error.
As mentioned, the code line is highlighted in an image below.

Private Sub Mt2415_Click()
'i 've structured my main table different to you (refer attached).
'Like in Excel I think it's a good idea to keep data separate and then
'join it you need to as the SQL statement that is failing for you (works for me)
'is doing. Based on your field names try the following (you will have change
'the name of the textbox (I used "txtSearchText")
'on your form that captures the user's search text):

 This is the l line:
[code]
varItem = AlphaOnly(CStr(varItem)) -->>>AlphaOnly is highlighted in blue if that helps.

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([txtKJV],""" & 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("txtKJV"), " ")
If IsNumeric(Left(varItem, 1)) = False Then
varItem = AlphaOnly(CStr(varItem)) --->Sub or Function not defined error at this line
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("txtKJV"), strVerseText & vbNewLine & k & " " & rs.Fields("txtKJV"))
rs.MoveNext
Loop
MsgBox strVerseText
End If
Set rs = Nothing: Set db = Nothing
End Sub
[/code]

Robert, this is so very important to me to develop this full app in Access because of the speed at which it runs
and the overall look in Access, and the rest of its functional capability, that I am more than willing to pay you for your
continued help - If it is both legal and ethical with MrExcel's terms and policies.

You have spent a whole lot of time helping me to this point, and I feel this is an unfair and unbalanced effort, me being the weaker link in this,
as I'm not up to speed on Access's VBA and database development as I am with Excel. Just to let you know that I take no one and nothing for granted. The displaying of the verses below the selected verse or text should also work for me as it does for you.

[tblTheBible] table structure images below if that would help.


Once again, thanks for all your help.
cr

 

[Trebor76]

Hi Charles,

Did you also copy the User Defined Function (UDF) I wrote - it would seem not:

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

    Set objRegExpr = Nothing
  
End Function

I am more than willing to pay you for your continued help

No, thank you but this is a free forum and that wouldn't be fair to all the others who post here.

I see in my code there are some bold tags [NOPARSE]"some text"[/NOPARSE]<' like here...

MsgBox """" & Me.Controls("[B]txtSearchText[/B]").Value & """ was not found in the source table.", vbExclamation

...which should be removed.

I also found the code won't find any matches if just 24 or 15 is entered. It does is 24:15 is entered. I take it (hope) that's ok.

Regards,

Robert

 

[chazrab]

Hi Robert. New error code. I coped the Function End Function into a module as well as at the top (General) of the Form Load code
{code]
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([txtKJV],""" & Controls("txtSearchText").Value & """)>0;"
Set db = CurrentDb: Set rs = db.OpenRecordset(strSQL) '---->Error here: "Too few parameters expected 1"
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
[/code]

Function as copied into module and form:

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, "")
    Set objRegExpr = Nothing
End Function

" It does is 24:15 is entered. I take it (hope) that's ok." No problem. Verses in the source table are of the format Matthew 24:15.