Hi Respree!
Here is your VBA routine. Paste it into a new Module. The usual
cautions about wrapped lines apply. Please let me know if you need
anything clarified.
The routine assumes that you have two tables already existing:
Table: tblTitles
Field Name Type
--------------------------------
SKU Number Primary Key
Title Text Field Size: 255
Table: tblTitleCount
Field Name Type
--------------------------------
Title Text Primary Key
TitleCount Number
' ***** Code Begin
Public Sub ParseTitlesForCount()
On Error GoTo ErrHandler
Dim cnn As ADODB.Connection
Dim rstTitles As ADODB.Recordset
Dim rstWordCount As ADODB.Recordset
Dim astrKeywords() As String
Dim strSQL As String
Dim strLastKey As String
Dim intLoop As Integer
Dim intCount As Integer
Set cnn = CurrentProject.Connection
Set rstTitles = New ADODB.Recordset
' Build a temporary recordset in memory
Set rstWordCount = New ADODB.Recordset
With rstWordCount
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.Fields.Append "Keyword", adVarChar, 255
.Fields.Refresh
.Open
End With
' Clear existing records from temp table
cnn.Execute ("DELETE * FROM tblTitleCount;")
' Select all Titles
strSQL = "SELECT Title FROM tblTitles;"
rstTitles.Open strSQL, cnn, adOpenStatic, adLockOptimistic
' Cycle through the titles using the Split function to
' parse each title into individual keywords
If Not rstTitles.BOF And Not rstTitles.EOF Then
rstTitles.MoveFirst
Do Until rstTitles.EOF
astrKeywords = Split(rstTitles!Title, " ")
For intLoop = 0 To UBound(astrKeywords)
' Add each keyword to the temp recordset
rstWordCount.AddNew
rstWordCount!Keyword = astrKeywords(intLoop)
rstWordCount.Update
' Clean up memory
astrKeywords(intLoop) = ""
Next intLoop
rstTitles.MoveNext
Loop
' Sort by the keyword
rstWordCount.Sort = "Keyword"
' Count the occurences
intCount = 0
strLastKey = ""
If Not rstWordCount.BOF And Not rstWordCount.EOF Then
rstWordCount.MoveFirst
Do Until rstWordCount.EOF
If Not strLastKey = "" Then
' When the value changes, write the current value
' and count and reset the counter
If Not strLastKey = rstWordCount!Keyword Then
strSQL = "INSERT INTO tblTitleCount (Title,
TitleCount) VALUES ('" & strLastKey & "', '" & intCount & "');"
cnn.Execute (strSQL)
intCount = 0
End If
End If
intCount = intCount + 1
strLastKey = rstWordCount!Keyword
rstWordCount.MoveNext
Loop
' Insert the last value and count
strSQL = "INSERT INTO tblTitleCount (Title, TitleCount)
VALUES ('" & strLastKey & "', '" & intCount & "');"
cnn.Execute (strSQL)
End If
End If
ExitMe:
On Error Resume Next
' Clean up memory
strSQL = ""
strLastKey = ""
If rstTitles.State = adStateOpen Then
rstTitles.Close
End If
Set rstTitles = Nothing
If rstWordCount.State = adStateOpen Then
rstWordCount.Close
End If
Set rstWordCount = Nothing
Set cnn = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitMe
End Sub
' ***** Code End
Best regards,
- Hammer |
Request for Answer Clarification by
respree-ga
on
28 May 2003 12:57 PDT
Hi Hammer:
Somehow, I had a feeling you'd be coming to my rescue again. Thanks.
I'm getting an error message as I run it against my live file. I'm
not sure if this is making a difference, but I gave you a bad example.
The SKU field is actually text (not numeric), but I'm not sure if
that is what is causing the error.
The error message I'm getting is:
"Syntax error (missing operator) in query expression
"(1930's','2');'."
Looks like there's more of the error code, but the full error message
appears to be cut off in the error message box.
It looks like its making it part of the way. Here's partial snapshot
of tblTitleCount (produces 116) records. Perhaps its not considering
some contingencies (title may have a single apostrophe, i.e. 1920's).
tblTitles has about 83,000 records, FYI.
Title TitleCount
! 23
# 14
#01.193 1
#01.199 1
#05 1
#06 1
#1 156
#1, 1
#10 29
#101-102 2
#11 31
#113-114 2
#114 1
#115 1
#115-116 2
#116 1
#117 1
<snip>
If you could correct the syntax error, that would be wonderful.
Thanks very much for your help.
|
Clarification of Answer by
hammer-ga
on
28 May 2003 13:04 PDT
Dang those single quotes! Use this routine instead. The change is
that, in the INSERT statements, ' is replaced with Chr(34), which
produces quotes.
- Hammer
Public Sub ParseTitlesForCount()
On Error GoTo ErrHandler
Dim cnn As ADODB.Connection
Dim rstTitles As ADODB.Recordset
Dim rstWordCount As ADODB.Recordset
Dim astrKeywords() As String
Dim strSQL As String
Dim strLastKey As String
Dim intLoop As Integer
Dim intCount As Integer
Set cnn = CurrentProject.Connection
Set rstTitles = New ADODB.Recordset
' Build a temporary recordset in memory
Set rstWordCount = New ADODB.Recordset
With rstWordCount
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.Fields.Append "Keyword", adVarChar, 255
.Fields.Refresh
.Open
End With
' Clear existing records from temp table
cnn.Execute ("DELETE * FROM tblTitleCount;")
' Select all Titles
strSQL = "SELECT Title FROM tblTitles;"
rstTitles.Open strSQL, cnn, adOpenStatic, adLockOptimistic
' Cycle through the titles using the Split function to
' parse each title into individual keywords
If Not rstTitles.BOF And Not rstTitles.EOF Then
rstTitles.MoveFirst
Do Until rstTitles.EOF
astrKeywords = Split(rstTitles!Title, " ")
For intLoop = 0 To UBound(astrKeywords)
' Add each keyword to the temp recordset
rstWordCount.AddNew
rstWordCount!Keyword = astrKeywords(intLoop)
rstWordCount.Update
' Clean up memory
astrKeywords(intLoop) = ""
Next intLoop
rstTitles.MoveNext
Loop
' Sort by the keyword
rstWordCount.Sort = "Keyword"
' Count the occurences
intCount = 0
strLastKey = ""
If Not rstWordCount.BOF And Not rstWordCount.EOF Then
rstWordCount.MoveFirst
Do Until rstWordCount.EOF
If Not strLastKey = "" Then
' When the value changes, write the current value
' and count and reset the counter
If Not strLastKey = rstWordCount!Keyword Then
strSQL = "INSERT INTO tblTitleCount (Title,
TitleCount) VALUES (" & Chr(34) & strLastKey & Chr(34) & ", '" &
intCount & "');"
cnn.Execute (strSQL)
intCount = 0
End If
End If
intCount = intCount + 1
strLastKey = rstWordCount!Keyword
rstWordCount.MoveNext
Loop
' Insert the last value and count
strSQL = "INSERT INTO tblTitleCount (Title, TitleCount)
VALUES (" & Chr(34) & strLastKey & Chr(34) & ", '" & intCount & "');"
cnn.Execute (strSQL)
End If
End If
ExitMe:
On Error Resume Next
' Clean up memory
strSQL = ""
strLastKey = ""
If rstTitles.State = adStateOpen Then
rstTitles.Close
End If
Set rstTitles = Nothing
If rstWordCount.State = adStateOpen Then
rstWordCount.Close
End If
Set rstWordCount = Nothing
Set cnn = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitMe
End Sub
|
,
0 Comments
)