Dear All,
I need your help for MS Access VBA Search Result performance improvement, below is the code which i used, i want to get the result based on string matching on % basis, this code is correct but it is taking too much time to perform almost 25 Minutes To 30 Minutes for Single String.
I have 3 tables
(1) MasterTable (Linked with SQL Server with 30 Lacs Records)
a. OM_ACCT_NBR (Text Primary Key)
b. Customer_Informations (Memo)
(2) tblSearchString (Using this table as Search String for bulk search)
a. Your_Search_String (Memo)
(3) tblResults (Store Matched Details)
a. OM_ACCT_NBR (Text)
b. Matched_% (Text)
c. Customer_Informations (Memo)
Example : If my search string = “Arjun Singh Pune Maharashtra 511015 CRXPS0288X”, i want >80% string matching result on Result Table.
This string will check one to one & Apple to Apple on Customer_Informations (Memo) Master Table.
Private Sub cmdSearch_Click()
Dim varRet 'Variant Array to hold Elements of [Your_Search_String]
Dim intCtr As Integer 'Used to Loop thru Elements of [Your_Search_String]
Dim intNumOfMatches As Integer 'Number of Matches (Elements in [Your_Search_String]
Dim intOverallCtr As Integer 'Overall Counter (Number of Elements in [Your_Search_String])
Dim conPERCENTAGE As Single
conPERCENTAGE = CInt(Me.txtMatchingPercentage) / 100 '> this Value on [Your_Search_String] Elements indicates Match
Dim TempTextMatched As String
Dim con As ADODB.Connection
Set con = Application.CurrentProject.Connection
Dim RsResult As Object
Set RsResult = CreateObject("ADODB.Recordset")
Dim RsSearchString As Object
Set RsSearchString = CreateObject("ADODB.Recordset")
Dim RsMasterTable As Object
Set RsMasterTable = CreateObject("ADODB.Recordset")
'Clear the Results Table
CurrentDb.Execute "DELETE * FROM tblResults", dbFailOnError
Me.Refresh
RsSearchString.Open "Select * from tblSearchString", con, 1, 3, dbSeeChanges
RsMasterTable.Open "Select * from De_Dupe_Final_db_Consolidated_Final_PercentMatching", con, adOpenForwardOnly, adLockReadOnly, adCmdText 'dbSeeChanges
RsResult.Open "Select * from tblResults", con, 1, 3, dbSeeChanges
With RsSearchString
Do While Not .EOF
Do While Not RsMasterTable.EOF
TempTextMatched = ""
varRet = Split(![Your_Search_String], " ")
For intCtr = LBound(varRet) To UBound(varRet)
intOverallCtr = intOverallCtr + 1
If InStr(Replace(RsMasterTable![Customer_Informations], " ", ""), varRet(intCtr)) > 0 Then
intNumOfMatches = intNumOfMatches + 1
TempTextMatched = TempTextMatched & Trim(varRet(intCtr)) & " "
End If
Next
'Do > 80% of Elements in [Your_Search_String] match [Customer_Informations]
If (intNumOfMatches / intOverallCtr) >= conPERCENTAGE Then 'Percentage Criteria for a 'MATCH'
RsResult.AddNew
RsResult![OM_ACCT_NBR] = RsMasterTable![OM_ACCT_NBR]
RsResult![Customer_Informations] = RsMasterTable![Customer_Informations]
RsResult![Matched_%] = intNumOfMatches / intOverallCtr
RsResult.Update
End If
intNumOfMatches = 0: intOverallCtr = 0 'RESET, critical
RsMasterTable.MoveNext
Loop
RsMasterTable.MoveFirst
.MoveNext
Loop
End With
RsSearchString.Close
Set RsSearchString = Nothing
RsMasterTable.Close
Set RsMasterTable = Nothing
RsResult.Close
Set RsResult = Nothing
Set con = Nothing
Me.Refresh
End Sub
I need your help for MS Access VBA Search Result performance improvement, below is the code which i used, i want to get the result based on string matching on % basis, this code is correct but it is taking too much time to perform almost 25 Minutes To 30 Minutes for Single String.
I have 3 tables
(1) MasterTable (Linked with SQL Server with 30 Lacs Records)
a. OM_ACCT_NBR (Text Primary Key)
b. Customer_Informations (Memo)
(2) tblSearchString (Using this table as Search String for bulk search)
a. Your_Search_String (Memo)
(3) tblResults (Store Matched Details)
a. OM_ACCT_NBR (Text)
b. Matched_% (Text)
c. Customer_Informations (Memo)
Example : If my search string = “Arjun Singh Pune Maharashtra 511015 CRXPS0288X”, i want >80% string matching result on Result Table.
This string will check one to one & Apple to Apple on Customer_Informations (Memo) Master Table.
Private Sub cmdSearch_Click()
Dim varRet 'Variant Array to hold Elements of [Your_Search_String]
Dim intCtr As Integer 'Used to Loop thru Elements of [Your_Search_String]
Dim intNumOfMatches As Integer 'Number of Matches (Elements in [Your_Search_String]
Dim intOverallCtr As Integer 'Overall Counter (Number of Elements in [Your_Search_String])
Dim conPERCENTAGE As Single
conPERCENTAGE = CInt(Me.txtMatchingPercentage) / 100 '> this Value on [Your_Search_String] Elements indicates Match
Dim TempTextMatched As String
Dim con As ADODB.Connection
Set con = Application.CurrentProject.Connection
Dim RsResult As Object
Set RsResult = CreateObject("ADODB.Recordset")
Dim RsSearchString As Object
Set RsSearchString = CreateObject("ADODB.Recordset")
Dim RsMasterTable As Object
Set RsMasterTable = CreateObject("ADODB.Recordset")
'Clear the Results Table
CurrentDb.Execute "DELETE * FROM tblResults", dbFailOnError
Me.Refresh
RsSearchString.Open "Select * from tblSearchString", con, 1, 3, dbSeeChanges
RsMasterTable.Open "Select * from De_Dupe_Final_db_Consolidated_Final_PercentMatching", con, adOpenForwardOnly, adLockReadOnly, adCmdText 'dbSeeChanges
RsResult.Open "Select * from tblResults", con, 1, 3, dbSeeChanges
With RsSearchString
Do While Not .EOF
Do While Not RsMasterTable.EOF
TempTextMatched = ""
varRet = Split(![Your_Search_String], " ")
For intCtr = LBound(varRet) To UBound(varRet)
intOverallCtr = intOverallCtr + 1
If InStr(Replace(RsMasterTable![Customer_Informations], " ", ""), varRet(intCtr)) > 0 Then
intNumOfMatches = intNumOfMatches + 1
TempTextMatched = TempTextMatched & Trim(varRet(intCtr)) & " "
End If
Next
'Do > 80% of Elements in [Your_Search_String] match [Customer_Informations]
If (intNumOfMatches / intOverallCtr) >= conPERCENTAGE Then 'Percentage Criteria for a 'MATCH'
RsResult.AddNew
RsResult![OM_ACCT_NBR] = RsMasterTable![OM_ACCT_NBR]
RsResult![Customer_Informations] = RsMasterTable![Customer_Informations]
RsResult![Matched_%] = intNumOfMatches / intOverallCtr
RsResult.Update
End If
intNumOfMatches = 0: intOverallCtr = 0 'RESET, critical
RsMasterTable.MoveNext
Loop
RsMasterTable.MoveFirst
.MoveNext
Loop
End With
RsSearchString.Close
Set RsSearchString = Nothing
RsMasterTable.Close
Set RsMasterTable = Nothing
RsResult.Close
Set RsResult = Nothing
Set con = Nothing
Me.Refresh
End Sub