I need help to solve this...thanks

P

Paul Mak

I have a procedure to search a table using a pre-defined "keywords" from the
keywords table. Then the result export to an Excel file and the match text
in the Excel file is highlighted. The procedure is as follow:

I set up the stopper at the begining of the process so that I can
trouble-shoot it. The Sub "KeywordSearch" went without a problem, then the
Sub "sCopyFromRS" went without an error either, however the last Sub routine
"FindAndHighlight" went into a infinite loop. Please help. Thanks.



Option Compare Database
Option Explicit
Const strQuote = """"
Public Sub KeywordSearch()
Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim strSearch As String


Set db = CurrentDb
Set rst1 = db.OpenRecordset("SELECT Tbl_CYSN_Keywords.CYSNKeywordID,
Tbl_CYSN_Keywords.CYSNKeyword FROM Tbl_CYSN_Keywords;")

DoCmd.SetWarnings False
'Delete old records in Tbl_CYSN Temp
DoCmd.RunSQL "DELETE [Tbl_CYSN_Search_Result].* FROM
[Tbl_CYSN_Search_Result];"

'Loop CYSN keywords table to search on the Tbl_CYSN
On Error Resume Next
If Not rst1.BOF Then
rst1.MoveFirst
Do While Not rst1.EOF
Debug.Print rst1!CYSNKeywordID
strSearch = strQuote & "*" & rst1!CYSNKeyword & "*" & strQuote
Debug.Print strSearch
'Append keywords search result to Tbl_CYSN Temp
DoCmd.RunSQL "INSERT INTO Tbl_CYSN_Search_Result ( ID, Country,
[Province/State], FRN, Version, AllPrincipalInvestigators, CoInvestigators,
CoApplicants, Supervisors, ProgramType, ProgramFamily, Program,
ParentInstitution, ResearchInstitution, InstitutionPaid, EffectiveDate,
ExpiryDate, FiscalYear, Funding, ProjectTitle, Keywords, ResearchArea,
ResearchClass, Institute, Theme, DataSource, DateCreated ) " & _
"SELECT [Tbl_CIHR Data_1].ID, [Tbl_CIHR
Data_1].Country, [Tbl_CIHR Data_1].[Province/State], [Tbl_CIHR Data_1].FRN,
[Tbl_CIHR Data_1].Version, [Tbl_CIHR Data_1].AllPrincipalInvestigators,
[Tbl_CIHR Data_1].CoInvestigators, [Tbl_CIHR Data_1].CoApplicants, [Tbl_CIHR
Data_1].Supervisors, [Tbl_CIHR Data_1].ProgramType, [Tbl_CIHR
Data_1].ProgramFamily, [Tbl_CIHR Data_1].Program, [Tbl_CIHR
Data_1].ParentInstitution, [Tbl_CIHR Data_1].ResearchInstitution, [Tbl_CIHR
Data_1].InstitutionPaid, [Tbl_CIHR Data_1].EffectiveDate, [Tbl_CIHR
Data_1].ExpiryDate, [Tbl_CIHR Data_1].FiscalYear, [Tbl_CIHR Data_1].Funding,
[Tbl_CIHR Data_1].ProjectTitle_1, [Tbl_CIHR Data_1].Keywords_1, [Tbl_CIHR
Data_1].ResearchArea_1, [Tbl_CIHR Data_1].ResearchClass, [Tbl_CIHR
Data_1].Institute, [Tbl_CIHR Data_1].Theme, [Tbl_CIHR Data_1].DataSource,
[Tbl_CIHR Data_1].DateCreated " & _
"FROM [Tbl_CIHR Data_1] " & _
"WHERE ((([Tbl_CIHR Data_1].ProjectTitle_1) Like " &
strSearch & ") Or (([Tbl_CIHR Data_1].Keywords_1)Like " & strSearch & ") Or
(([Tbl_CIHR Data_1].ResearchArea_1)Like " & strSearch & "));"
strSearch = vbNullString
rst1.MoveNext
Loop
End If
rst1.Close
Set rst1 = Nothing
Set db = Nothing
DoCmd.SetWarnings True
sCopyFromRS
End Sub

Sub sCopyFromRS()
'Send records to the first
'sheet in a new workbook
'
Dim rs As Recordset
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim objXL As Excel.Application
Dim objWkb As Workbook
Dim objSht As Worksheet
Set rs = CurrentDb.OpenRecordset("Tbl_CYSN_Search_Result", dbOpenSnapshot)
intMaxCol = rs.Fields.Count
If rs.RecordCount > 0 Then
rs.MoveLast: rs.MoveFirst
intMaxRow = rs.RecordCount
Set objXL = New Excel.Application
With objXL
.Visible = True
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)
With objSht
.Range(.Cells(1, 1), .Cells(intMaxRow, _
intMaxCol)).CopyFromRecordset rs
End With
End With
End If
FindAndHighlight
End Sub



Sub FindAndHighlight()
Dim c As Range
Dim iStart As Long
Dim iFound As Long
Dim s As String
Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim strKeyword As String

'Loop throught each keyword to find the match in the
Tbl_CYSN_Search_Result
Set db = CurrentDb
Set rst1 = db.OpenRecordset("SELECT Tbl_CYSN_Keywords.CYSNKeywordID,
Tbl_CYSN_Keywords.CYSNKeyword FROM Tbl_CYSN_Keywords;")
On Error Resume Next
If Not rst1.BOF Then
rst1.MoveFirst
Do While Not rst1.EOF
strKeyword = rst1!CYSNKeyword
Columns("T:V").Select
Cells.Find(What:=strKeyword, After:=ActiveCell,
LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
For Each c In Selection
s = c.Value
iStart = 1
iFound = InStr(iStart, s, strKeyword, vbTextCompare)

Do While iFound <> 0
With c.Characters(Start:=iFound,
Length:=Len(strKeyword)).Font
.FontStyle = "Bold"
.Color = vbRed
End With
iStart = iFound + 1
iFound = InStr(iStart, s, strKeyword,
vbTextCompare)
Loop
Next c
rst1.MoveNext
Loop
End If
rst1.Close
Set rst1 = Nothing
Set db = Nothing
End Sub
 
G

Guest

Paul Mak,

There is nothing obvious. Really pretty good looking code. What I would do
is set a breakpoint on the line * Do While iFound <> 0 * and walk through it
line by line with some watches on the variables you are using. My guess is
that iFound is never 0. I know it seems illogical, but I don't see anything
else that might be a problem.

Paul Mak said:
I have a procedure to search a table using a pre-defined "keywords" from the
keywords table. Then the result export to an Excel file and the match text
in the Excel file is highlighted. The procedure is as follow:

I set up the stopper at the begining of the process so that I can
trouble-shoot it. The Sub "KeywordSearch" went without a problem, then the
Sub "sCopyFromRS" went without an error either, however the last Sub routine
"FindAndHighlight" went into a infinite loop. Please help. Thanks.



Option Compare Database
Option Explicit
Const strQuote = """"
Public Sub KeywordSearch()
Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim strSearch As String


Set db = CurrentDb
Set rst1 = db.OpenRecordset("SELECT Tbl_CYSN_Keywords.CYSNKeywordID,
Tbl_CYSN_Keywords.CYSNKeyword FROM Tbl_CYSN_Keywords;")

DoCmd.SetWarnings False
'Delete old records in Tbl_CYSN Temp
DoCmd.RunSQL "DELETE [Tbl_CYSN_Search_Result].* FROM
[Tbl_CYSN_Search_Result];"

'Loop CYSN keywords table to search on the Tbl_CYSN
On Error Resume Next
If Not rst1.BOF Then
rst1.MoveFirst
Do While Not rst1.EOF
Debug.Print rst1!CYSNKeywordID
strSearch = strQuote & "*" & rst1!CYSNKeyword & "*" & strQuote
Debug.Print strSearch
'Append keywords search result to Tbl_CYSN Temp
DoCmd.RunSQL "INSERT INTO Tbl_CYSN_Search_Result ( ID, Country,
[Province/State], FRN, Version, AllPrincipalInvestigators, CoInvestigators,
CoApplicants, Supervisors, ProgramType, ProgramFamily, Program,
ParentInstitution, ResearchInstitution, InstitutionPaid, EffectiveDate,
ExpiryDate, FiscalYear, Funding, ProjectTitle, Keywords, ResearchArea,
ResearchClass, Institute, Theme, DataSource, DateCreated ) " & _
"SELECT [Tbl_CIHR Data_1].ID, [Tbl_CIHR
Data_1].Country, [Tbl_CIHR Data_1].[Province/State], [Tbl_CIHR Data_1].FRN,
[Tbl_CIHR Data_1].Version, [Tbl_CIHR Data_1].AllPrincipalInvestigators,
[Tbl_CIHR Data_1].CoInvestigators, [Tbl_CIHR Data_1].CoApplicants, [Tbl_CIHR
Data_1].Supervisors, [Tbl_CIHR Data_1].ProgramType, [Tbl_CIHR
Data_1].ProgramFamily, [Tbl_CIHR Data_1].Program, [Tbl_CIHR
Data_1].ParentInstitution, [Tbl_CIHR Data_1].ResearchInstitution, [Tbl_CIHR
Data_1].InstitutionPaid, [Tbl_CIHR Data_1].EffectiveDate, [Tbl_CIHR
Data_1].ExpiryDate, [Tbl_CIHR Data_1].FiscalYear, [Tbl_CIHR Data_1].Funding,
[Tbl_CIHR Data_1].ProjectTitle_1, [Tbl_CIHR Data_1].Keywords_1, [Tbl_CIHR
Data_1].ResearchArea_1, [Tbl_CIHR Data_1].ResearchClass, [Tbl_CIHR
Data_1].Institute, [Tbl_CIHR Data_1].Theme, [Tbl_CIHR Data_1].DataSource,
[Tbl_CIHR Data_1].DateCreated " & _
"FROM [Tbl_CIHR Data_1] " & _
"WHERE ((([Tbl_CIHR Data_1].ProjectTitle_1) Like " &
strSearch & ") Or (([Tbl_CIHR Data_1].Keywords_1)Like " & strSearch & ") Or
(([Tbl_CIHR Data_1].ResearchArea_1)Like " & strSearch & "));"
strSearch = vbNullString
rst1.MoveNext
Loop
End If
rst1.Close
Set rst1 = Nothing
Set db = Nothing
DoCmd.SetWarnings True
sCopyFromRS
End Sub

Sub sCopyFromRS()
'Send records to the first
'sheet in a new workbook
'
Dim rs As Recordset
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim objXL As Excel.Application
Dim objWkb As Workbook
Dim objSht As Worksheet
Set rs = CurrentDb.OpenRecordset("Tbl_CYSN_Search_Result", dbOpenSnapshot)
intMaxCol = rs.Fields.Count
If rs.RecordCount > 0 Then
rs.MoveLast: rs.MoveFirst
intMaxRow = rs.RecordCount
Set objXL = New Excel.Application
With objXL
.Visible = True
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)
With objSht
.Range(.Cells(1, 1), .Cells(intMaxRow, _
intMaxCol)).CopyFromRecordset rs
End With
End With
End If
FindAndHighlight
End Sub



Sub FindAndHighlight()
Dim c As Range
Dim iStart As Long
Dim iFound As Long
Dim s As String
Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim strKeyword As String

'Loop throught each keyword to find the match in the
Tbl_CYSN_Search_Result
Set db = CurrentDb
Set rst1 = db.OpenRecordset("SELECT Tbl_CYSN_Keywords.CYSNKeywordID,
Tbl_CYSN_Keywords.CYSNKeyword FROM Tbl_CYSN_Keywords;")
On Error Resume Next
If Not rst1.BOF Then
rst1.MoveFirst
Do While Not rst1.EOF
strKeyword = rst1!CYSNKeyword
Columns("T:V").Select
Cells.Find(What:=strKeyword, After:=ActiveCell,
LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
For Each c In Selection
s = c.Value
iStart = 1
iFound = InStr(iStart, s, strKeyword, vbTextCompare)

Do While iFound <> 0
With c.Characters(Start:=iFound,
Length:=Len(strKeyword)).Font
.FontStyle = "Bold"
.Color = vbRed
End With
iStart = iFound + 1
iFound = InStr(iStart, s, strKeyword,
vbTextCompare)
Loop
Next c
rst1.MoveNext
Loop
End If
rst1.Close
Set rst1 = Nothing
Set db = Nothing
End Sub
Click to expand...
 
G

Guest

Paul Mak said:
I have a procedure to search a table using a pre-defined "keywords" from the
keywords table. Then the result export to an Excel file and the match text
in the Excel file is highlighted. The procedure is as follow:

I set up the stopper at the begining of the process so that I can
trouble-shoot it. The Sub "KeywordSearch" went without a problem, then the
Sub "sCopyFromRS" went without an error either, however the last Sub routine
"FindAndHighlight" went into a infinite loop. Please help. Thanks.
Click to expand...
'****** SNIP *****

I modified your code for "FindAndHighlight" and tested it. I put three
entries in the range and ran the following code:

'***begin modified code *****
Sub FindAndHighlight()
Dim c As Range
Dim iStart As Long
Dim iFound As Long
Dim s As String
Dim strKeyword As String

strKeyword = "soft"
Columns("T:V").Select
Cells.Find(What:=strKeyword, After:=ActiveCell,
LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
For Each c In Selection
iStart = 1
iFound = InStr(iStart, s, strKeyword, vbTextCompare)

Do While iFound <> 0
With c.Characters(Start:=iFound,
Length:=Len(strKeyword)).Font
.FontStyle = "Bold"
.Color = vbRed
End With
iStart = iFound + 1
iFound = InStr(iStart, s, strKeyword,
vbTextCompare)
Loop
Next c

End Sub
'**** end modified code *******

I have an IBM P4/ 2.4G/ 512MB Ram/ XP Pro/ Office 2003 (at work).

It took ~16 seconds for one pass. Depending on how many keywords there are
in the table, it might seem like it locked up. You could have it Beep every
5,000 iterations or put a message in the Status line every 5,000 checks and
when the keyword changes.

The code is checking 3 columns X 65536 rows X however many keywords in the
table. Is there any way to limit the number of rows in the range? Maybe check
the .LastCell property and set the range from T1 to V (the last row) before
checking the keywords?

HTH
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Need Coding Advice 3
Help With Module - sorry, one more question 7
Almost Have It! One Part of Code incorrect though---Help! 2
Type Mismatch Error 2
Opening a recordset with parameters 4
automation to copy records from excel to an existing excel 3
exporting recordset to Excel, missing header 2
Function to export certain tables to Excel 0

Top