Solved

Excel Search finding patterns matches : Looking for exact string match within cell

Posted on 2003-10-30
30
383 Views
Last Modified: 2007-12-19
Excel2000
access2000
win2000 sp2

Previous reference post
http://www.experts-exchange.com/Applications/MS_Office/Q_20779494.html

I have the following routine searching working o.k.
Scenario:
Look at Sheet2 Column A values: Loop thorugh these values.

It trys to find a Match in the Column B on Worksheet "MyNewData".
If it finds a match the string is placed in Column A

Problem:
It is looking at any part of the string and bringing it back also:

Example:

Matches                         Description
222, 10, 22                       Loctite 222 10ml
1DE45, 22, 222                 MOTOR,  1A222 NUMBER PLASTIC FANS 1DE45


The search for criteria(Sheet2: ColumnA) for example purposes may contain:
222
22
1DE45
10

The result should only bring back:
Matches                         Description
222                             Loctite 222 10ml
1DE45                         MOTOR,  1A222 NUMBER PLASTIC FANS 1DE45


Sub compare()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim found As String
Dim tofind As String
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.Open "c:\test\MyFind.mdb"
End With
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open "SELECT * FROM tblLook"
End With
Sheets(2).Range("a1").CopyFromRecordset rst
Set rst = Nothing
conn.Close

'new changes start from here NO MESSAGE BOX.......
Range("A2:A65536").ClearContents
For counter = 1 To Sheets(2).UsedRange.Rows.Count
tofind = Sheets(2).Cells(counter, 1).Text
With Worksheets("MyNewData").Range("B2:B65536")
Set f = .Find(tofind, LookIn:=xlValues)
If Not f Is Nothing Then
firstAddress = f.Address
Do
Range(f.Address).Offset(0, -1).Activate
If ActiveCell.Value <> "" Then ActiveCell.Interior.Color = vbGreen
ActiveCell.Value = IIf(ActiveCell.Value = "", _
tofind, ActiveCell.Value & ", " & tofind)
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> firstAddress
End If
End With
Next counter
' -----------
End Sub



Thanks
fordraiders
 
0
Comment
Question by:fordraiders
  • 15
  • 9
  • 6
30 Comments
 
LVL 5

Expert Comment

by:joboy
Comment Utility
Hi,

I have been looking into this one for the past hour or so, and think I may have a solution for you.

I have written a new Find function that will hopefully achieve the result you want.  To use the function paste the code provided at the bottom of this post into a module, you'll then have a new function called "jbFind".  The syntax of this function is as follows...

Public Function jbFind(What, InRange,  LookIn, Match , Compare , Reset ) As Range

What = Required. The value to find

InRange = Required. The Range to search for the "What" value in.

LookIn = Optional. Can be XLValues, xlFormulas, or xlNotes. Default  = xlValues

Match = Optional. Determines how the match between the range contents and the "What" value should be made. Can be BeginsWith, EndsWith,  AnyWhere, FullLengthMatch, InnerLengthMatch, or a combination of any.  FullLengthMatch means that one values length should match exactly that of anothers, i.e. "200" = "200" Match Found, "2000" = "200" No Match.  InnerLengthMatch means that a string with a strings length should match, i.e. "200 Dogs" , "Dogs" Match Found, "200Dogs", "Dogs" No Match

Compare = Optional. Standard compare methods, ie .vbTextCompare etc.

Reset = Optional. Set to True to begin a search from the 1st cell of InRange, rather than from the last matching range found.


Basically you can use the "jbFind" method in a similar way to the "Find" method, except you don't use FindNext to keep searching through a range, rather you repeatably call "jbFind".

e.g.

Do
     Set rng = jbFind("E45",Range("A1:B6"),xlValues,InnerLengthMatch,vbTextCompare)
loop until rng is nothing

Hopefully this is enough information to get you started.  If not let me know... I'm about to have a late lunch but will be back shortly




===================================================
The Code - copy and paste into a module
===================================================
Option Explicit

Public Enum InStrPos
    BeginsWith = 1
    EndsWith = 2
    Anywhere = 4
    FullLengthMatch = 8
    InnerLengthMatch = 16
End Enum

Public Function jbFind(What As Variant, InRange As Range, _
  Optional LookIn As Integer = xlValues, Optional Match As InStrPos = Anywhere, _
  Optional Compare As VbCompareMethod, Optional Reset As Boolean = False) As Range
 
    Static rngLastRange As Excel.Range
    Static rngLastResult As Range
   
    Dim rng As Range
    Dim r As Long
    Dim c As Integer
    Dim StartRow As Long
    Dim StartColumn As Long
    Dim strValue As String
   
    If rngLastRange Is Nothing Or rngLastResult Is Nothing Or Reset Then
        Set rngLastResult = InRange.Cells(1, 1)
    ElseIf Not (rngLastRange.Address(external:=True) = InRange.Address(external:=True)) Then
        Set rngLastResult = InRange.Cells(1, 1)
    End If
   
    StartColumn = (rngLastResult.Column - InRange.Column) + 1
    StartRow = (rngLastResult.Row - InRange.Row) + 1
   
    For c = StartColumn To InRange.Columns.Count
        For r = StartRow To InRange.Rows.Count
            Set rng = InRange.Cells(r, c)
           
            Select Case LookIn
                Case xlValues
                    strValue = rng.Value
                Case xlFormulas
                    strValue = rng.Formula
                Case xlNotes
                    strValue = rng.Comment

            End Select
           
            If Len(strValue) > 0 Then
                If CompareText(strValue, What, Match, Compare) > 0 Then
                    Set jbFind = rng
                   
                    'Move the rng on
                    If rng.Column = InRange.Column + InRange.Columns.Count - 1 Then
                        If rng.Row = InRange.Row + InRange.Rows.Count - 1 Then
                            Set rng = Nothing
                        Else
                            Set rng = rng.Offset(1)
                        End If
                    ElseIf rng.Row < InRange.Row + InRange.Rows.Count - 1 Then
                        Set rng = rng.Offset(1)
                    Else
                        Set rng = InRange(1, rng.Column - InRange.Column + 2)
                    End If
                           
                    GoTo ExitProc
                End If
            Else
                Set rng = Nothing
            End If
        Next
        StartRow = 1
    Next
   
ExitProc:
    Set rngLastResult = rng
    Set rngLastRange = InRange
    Set rng = Nothing
End Function

Public Function CompareText(ByVal String1 As String, ByVal String2 As String, _
  Optional Match As InStrPos = Anywhere, Optional Compare As VbCompareMethod) As Long
    Dim n As Long, n2 As Long
    Dim strSwitchBuf As String
    Dim strChunk As String
   
    If (Match And FullLengthMatch) = FullLengthMatch And Len(String1) <> Len(String2) Then
        n = 0
    Else
        'Place the strings in the correct comparative order (i.e. short compares to long)
        If Len(String2) > Len(String1) Then
            strSwitchBuf = String2
            String2 = String1
            String1 = strSwitchBuf
        End If
        'Check if string 1 exists in string 2
        n = InStr(1, String1, String2, Compare)
       
        If n > 0 Then
            If (Match And InnerLengthMatch) = InnerLengthMatch Then
                For n2 = n To Len(String1)
                    strChunk = strChunk + Mid(String1, n2, 1)
                    If n2 > 1 And n2 = n Then
                        If Asc(Mid(String1, n2 - 1, 1)) > 34 Then
                            strChunk = ""
                            Exit For
                        End If
                    ElseIf n2 < Len(String1) Then
                        If Asc(Mid(String1, n2 + 1, 1)) < 34 Then Exit For
                    End If
                Next
               
                If Len(strChunk) <> Len(String2) Then
                    n = 0
                End If
            End If
           
            If (Match And BeginsWith) = BeginsWith And n > 1 Then
                n = 0
            ElseIf (Match And EndsWith) = EndsWith And n + Len(String2) - 1 < Len(String1) Then
                n = 0
            End If
        End If
   
    End If
   
    CompareText = n
End Function

0
 
LVL 24

Expert Comment

by:R_Rajesh
Comment Utility
Hi
I see that you still have not found a solution for your problem. The problem with what you are asking for is that there is no way to know which string you want
For example:
1DE45, 22, 222                 MOTOR,  1A222 NUMBER PLASTIC FANS 1DE45

in the above line you said you wanted 1DE45 in column a but unfortunately 1A222 also exists in the sting so how do we decide what to keep and what to dicard, since both the value exist in the database i.e. how do we decide if we want 1A222 of 1DE45 in column A

Rajesh
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
To All,
The problem is the code is extracting substrings/substrings from strings..

It is finding  22  inside  1A222

Or if 45 was in the list it is finding 45 inside of  1DE45..

It's not that I don't want to return 1DE45 OR 1A222 .... I don't need it to find substrings inside of other strings.

Hope this helps...
Otherwise the code is working great.
Thanks
fordraiders
0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
Using the provided jbFind method (provided above) and setting the Match proprerty to InnerLengthMatch you should find that this achieves the result you want. ie, It will ignore the instance of "45" in "1DE45", but will capture the "45" in "I have 45 dogs"
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
o.k.,
So is this correct?

Range("A2:A65536").ClearContents
For counter = 1 To Sheets(2).UsedRange.Rows.Count
tofind = Sheets(2).Cells(counter, 1).Text
With Worksheets("MyNewData").Range("B2:B65536")
'Set f = Selection.Find(What:=tofind, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'Set f = .Find(tofind, LookIn:=xlValues)
Set rng = jbFind(tofind, Range("B2:B65536"), xlValues, InnerLengthMatch, vbTextCompare)
If Not rng Is Nothing Then
firstAddress = rng.Address
Do
Range(rng.Address).Offset(0, -1).Activate
If ActiveCell.Value <> "" Then ActiveCell.Interior.Color = vbGreen
ActiveCell.Value = IIf(ActiveCell.Value = "", _
tofind, ActiveCell.Value & ", " & tofind)
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> firstAddress
End If
End With
Next counter

Do i need to declare anything ?

Thanks
fordraiders
0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
See slightly ammended code below - there are two ammendments marked with the **NEW** comment.

I'm just looking at the fact you pass in 65,000 rows to be checked.  Because of this if you find the finding procedure slow we may need to make a few code alterations.. see how you get on.



'** NEW ** - DECLARATION
'You need to declare the "rng" object or replace the "rng" with the "f" object you've already declared
Dim rng As Excel.Range
'************

Range("A2:A65536").ClearContents
For counter = 1 To Sheets(2).UsedRange.Rows.Count
tofind = Sheets(2).Cells(counter, 1).Text
With Worksheets("MyNewData").Range("B2:B65536")
'Set f = Selection.Find(What:=tofind, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'Set f = .Find(tofind, LookIn:=xlValues)
Set rng = jbFind(tofind, Range("B2:B65536"), xlValues, InnerLengthMatch, vbTextCompare)
If Not rng Is Nothing Then
firstAddress = rng.Address
Do
Range(rng.Address).Offset(0, -1).Activate
If ActiveCell.Value <> "" Then ActiveCell.Interior.Color = vbGreen
ActiveCell.Value = IIf(ActiveCell.Value = "", _
tofind, ActiveCell.Value & ", " & tofind)

'**NEW**  -NOTE THE CHANGE TO THE .FindNext statement to the jbFind statement in the next line
Set rng = jbFind(rng, Range("B2:B65536"), xlValues, InnerLengthMatch, vbTextCompare)
'****
Loop While Not rng Is Nothing And rng.Address <> firstAddress
End If
End With
Next counter
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
joboy,
It finds one match and then I get an error....

Loop While Not rnb Is Nothing And rnb.Address <> firstAddress    <----- ON THIS LINE    
error runtime error 91 "Object varaible or with block variable not set"


tHANKS\
FORDRAIDERS
0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
>Loop While Not rnb Is Nothing And rnb.Address <> firstAddress    <----- ON THIS LINE  

Shoud read..

Loop While Not rng Is Nothing And rng.Address <> firstAddress    <----- ON THIS LINE  

..Although I'm suprised that this line never got an error before because if rng Is Nothing then you can't check its address, for this reason you might want to consider ammending the line to

If rng.Address <> firstAddress Then
    Set rng = Nothing
End if
Loop While Not rng Is Nothing
0
 
LVL 24

Accepted Solution

by:
R_Rajesh earned 500 total points
Comment Utility
Hey !  fordraiders,

I have made some changes but have not commented them, this code searches for whole string only. if you have any questions be sure to post them

----------------------
Sub compare()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim found As String
Dim tofind As String
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.Open "c:\test\MyFind.mdb"
End With
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open "SELECT * FROM tblLook"
End With
Sheets(2).Range("a1").CopyFromRecordset rst
Set rst = Nothing
conn.Close
'main code with changes begins
Range("A2:A65536").ClearContents
For counter = 1 To Sheets(2).UsedRange.Rows.Count
tofind = Sheets(2).Cells(counter, 1).Text
With Sheets("MyNewData").Range("B2:B65536")
Set f = .Find(tofind, LookIn:=xlValues)
If Not f Is Nothing Then
firstAddress = f.Address
Do
Range(f.Address).Activate
'check if its a whole word
a1 = InStr(1, ActiveCell.Value, tofind, 1)
If a1 > 1 Then
b1 = Mid(ActiveCell.Text, a1 - 1, 1)
Else
b1 = " "
End If
If (a1 + Len(tofind)) - 1 = Len(ActiveCell.Text) Then
d1 = " "
Else
d1 = Mid(ActiveCell.Text, a1 + Len(tofind), 1)
End If
If b1 = "#" Or b1 = "-" Or b1 = "," Or b1 = "/" Then b1 = " "
If d1 = "#" Or d1 = "-" Or d1 = "," Or d1 = "/" Then d1 = " "
If b1 <> " " Or d1 <> " " Then
GoTo nn
b1 = " ": d1 = " "
End If
'end check for whole word
Range(f.Address).Offset(0, -1).Activate
If ActiveCell.Value <> "" Then ActiveCell.Interior.Color = vbGreen
ActiveCell.Value = IIf(ActiveCell.Value = "", _
tofind, ActiveCell.Value & ", " & tofind)
nn:
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> firstAddress
End If
End With
Next counter
End Sub
---------------------
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
joboy Sorry,
My fault I have 2 "set"  lines active....

It is working o.k. ?  but ....
If it finds another match in a string it does not add the new item appropriately.
and yes The code is slow because it is looking at 65536 cells..

Matches                         Description
222                             Loctite 222 10ml
1DE45, 1A222              MOTOR,  1A222 NUMBER PLASTIC FANS 1DE45

Actually it does on the first row but will not after that.

Also if it is looking for 1A222 but   1A222,   HAS A COMMA behind it it will not bring the result back

But working good otherwise.
Thanks
fordraiders
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
R_Rajesh

Worked great....
Until, I got to a blank cell....in column b  sheet 2

So I added:  
If Not f Is Nothing Then
firstAddress = f.Address
Do
If tofind = "" Then Exit Sub   <------- to look for end of Sheet2 data
Range(f.Address).Activate
'check if its a whole word
etc..................................

Thanks
fordraiders

0
 
LVL 24

Expert Comment

by:R_Rajesh
Comment Utility
great,

you  could also try sorting column b of sheet2 so any blank cells will be sent to the end. the code below does that it also loops through only the used range in sheet a hopefully this should speed up your code. just replace the existng code with this one
---------------
Range("A2:A65536").ClearContents
Sheets(2).Select
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
Sheets("MyNewData").Select
For counter = 1 To Sheets(2).UsedRange.Rows.Count
tofind = Sheets(2).Cells(counter, 1).Text
With Sheets("MyNewData").Range(Cells(2, 2), Cells(ActiveSheet.UsedRange.Rows.Count, 2))
------------------------
0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
The following code replaces the code posted earlier.  It includes a speed tweak and the ability to handle the find "1A222" in  "1A222," situation.

> can you clarifiy what exactly is happening when you say "If it finds another match in a string it does not add the new item appropriately."

Thanks,

Joseph




Option Explicit

Public Enum InStrPos
    BeginsWith = 1
    EndsWith = 2
    Anywhere = 4
    FullLengthMatch = 8
    InnerLengthMatch = 16
End Enum

Public Function jbFind(What As Variant, InRange As Range, _
  Optional LookIn As Integer = xlValues, Optional Match As InStrPos = Anywhere, _
  Optional Compare As VbCompareMethod, Optional Reset As Boolean = False) As Range
 
    Static rngLastRange As Excel.Range
    Static rngLastResult As Range
   
    Dim rng As Range
    Dim r As Long
    Dim c As Integer
    Dim StartRow As Long
    Dim StartColumn As Long
    Dim strValue As String
   
    If rngLastRange Is Nothing Or rngLastResult Is Nothing Or Reset Then
        Set rngLastResult = InRange.Cells(1, 1)
    ElseIf Not (rngLastRange.Address(external:=True) = InRange.Address(external:=True)) Then
        Set rngLastResult = InRange.Cells(1, 1)
    End If
   
    StartColumn = (rngLastResult.Column - InRange.Column) + 1
    StartRow = (rngLastResult.Row - InRange.Row) + 1
   
    For c = StartColumn To Intersect(InRange.Worksheet.UsedRange, InRange).Columns.Count
        For r = StartRow To Intersect(InRange.Worksheet.UsedRange, InRange).Rows.Count
            Set rng = InRange.Cells(r, c)
           
            Select Case LookIn
                Case xlValues
                    strValue = rng.Value
                Case xlFormulas
                    strValue = rng.Formula
                Case xlNotes
                    strValue = rng.Comment

            End Select
           
            If Len(strValue) > 0 Then
                If CompareText(strValue, What, Match, Compare) > 0 Then
                    Set jbFind = rng
                   
                    'Move the rng on
                    If rng.Column = InRange.Column + InRange.Columns.Count - 1 Then
                        If rng.Row = InRange.Row + InRange.Rows.Count - 1 Then
                            Set rng = Nothing
                        Else
                            Set rng = rng.Offset(1)
                        End If
                    ElseIf rng.Row < InRange.Row + InRange.Rows.Count - 1 Then
                        Set rng = rng.Offset(1)
                    Else
                        Set rng = InRange(1, rng.Column - InRange.Column + 2)
                    End If
                           
                    GoTo ExitProc
                End If
            Else
                Set rng = Nothing
            End If
        Next
        StartRow = 1
    Next
   
ExitProc:
    Set rngLastResult = rng
    Set rngLastRange = InRange
    Set rng = Nothing
End Function

Public Function CompareText(ByVal String1 As String, ByVal String2 As String, _
  Optional Match As InStrPos = Anywhere, Optional Compare As VbCompareMethod) As Long
    Dim n As Long, n2 As Long
    Dim strSwitchBuf As String
    Dim strChunk As String
   
    If (Match And FullLengthMatch) = FullLengthMatch And Len(String1) <> Len(String2) Then
        n = 0
    Else
        'Place the strings in the correct comparative order (i.e. short compares to long)
        If Len(String2) > Len(String1) Then
            strSwitchBuf = String2
            String2 = String1
            String1 = strSwitchBuf
        End If
        'Check if string 1 exists in string 2
        n = InStr(1, String1, String2, Compare)
       
        If n > 0 Then
            If (Match And InnerLengthMatch) = InnerLengthMatch Then
                For n2 = n To Len(String1)
                    strChunk = strChunk + Mid(String1, n2, 1)
                    If n2 > 1 And n2 = n Then
                        If Asc(Mid(String1, n2 - 1, 1)) > 47 Then
                            n2 = InStr(n2 + 1, String1, String2, Compare) - 1
                            strChunk = ""
                            If n2 = -1 Then Exit For
                        End If
                    ElseIf n2 < Len(String1) Then
                        If Asc(Mid(String1, n2 + 1, 1)) < 47 Then Exit For
                    End If
                Next
               
                If Len(strChunk) <> Len(String2) Then
                    n = 0
                End If
            End If
           
            If (Match And BeginsWith) = BeginsWith And n > 1 Then
                n = 0
            ElseIf (Match And EndsWith) = EndsWith And n + Len(String2) - 1 < Len(String1) Then
                n = 0
            End If
        End If
   
    End If
   
    CompareText = n
End Function
0
 
LVL 24

Expert Comment

by:R_Rajesh
Comment Utility
sorry did you say column b of sheet 2 i thought we were pasting the database values to column a of sheet2 ?
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
joboy,


Returning
1DE45                 MOTOR,  1A222 NUMBER PLASTIC FANS 1DE45

loops find 1A222 should add  1A222 TO 1DE45


Should be
1DE45, 1A222              MOTOR,  1A222 NUMBER PLASTIC FANS 1DE45

Thanks
fordraiders
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 3

Author Comment

by:fordraiders
Comment Utility
Rajesh,
Sorry, You are correct...
I guess what I'am saying  is When the cope reaches  tofind =  "" then I guess it shouls stop processing.

I know there is code to define a used range and use that instead of looking at the whole sheet.

But it was easier just to say  

if tofind = "" then exit sub  

Thanks

fordraiders




0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
OK, I think I understand the problem... currently my Find procedure simply continues to search from the last good match.  This means that after it's found "1DE45" in "MOTOR,  1A222 NUMBER PLASTIC FANS 1DE45", when you then do a search for "1A222" the line gets skipped because the search thinks it's already found a match in that line.

I've made an ammendment to the jbFind procedure that might solve this problem (see ammended code below), however, with this in mind I am now suspecting the R_Rajesh's solutions going to work best.

Thanks,
Joboy


=============================
Public Function jbFind(What As Variant, InRange As Range, _
  Optional LookIn As Integer = xlValues, Optional Match As InStrPos = Anywhere, _
  Optional Compare As VbCompareMethod, Optional Reset As Boolean = False) As Range
 
    Static rngLastRange As Excel.Range
    Static rngLastResult As Range
    Static vntLastWhat As Variant
   
    Dim rng As Range
    Dim r As Long
    Dim c As Integer
    Dim StartRow As Long
    Dim StartColumn As Long
    Dim strValue As String
   
    If rngLastRange Is Nothing Or rngLastResult Is Nothing Or Reset Or vntLastWhat <> What Then
        Set rngLastResult = InRange.Cells(1, 1)
    ElseIf Not (rngLastRange.Address(external:=True) = InRange.Address(external:=True)) Then
        Set rngLastResult = InRange.Cells(1, 1)
    End If
   
    StartColumn = (rngLastResult.Column - InRange.Column) + 1
    StartRow = (rngLastResult.Row - InRange.Row) + 1
   
    For c = StartColumn To Intersect(InRange.Worksheet.UsedRange, InRange).Columns.Count
        For r = StartRow To Intersect(InRange.Worksheet.UsedRange, InRange).Rows.Count
            Set rng = InRange.Cells(r, c)
           
            Select Case LookIn
                Case xlValues
                    strValue = rng.Value
                Case xlFormulas
                    strValue = rng.Formula
                Case xlNotes
                    strValue = rng.Comment

            End Select
           
            If Len(strValue) > 0 Then
                If CompareText(strValue, What, Match, Compare) > 0 Then
                    Set jbFind = rng
                   
                    'Move the rng on
                    If rng.Column = InRange.Column + InRange.Columns.Count - 1 Then
                        If rng.Row = InRange.Row + InRange.Rows.Count - 1 Then
                            Set rng = Nothing
                        Else
                            Set rng = rng.Offset(1)
                        End If
                    ElseIf rng.Row < InRange.Row + InRange.Rows.Count - 1 Then
                        Set rng = rng.Offset(1)
                    Else
                        Set rng = InRange(1, rng.Column - InRange.Column + 2)
                    End If
                           
                    GoTo ExitProc
                End If
            Else
                Set rng = Nothing
            End If
        Next
        StartRow = 1
    Next
   
ExitProc:
    vntLastWhat = What
    Set rngLastResult = rng
    Set rngLastRange = InRange
    Set rng = Nothing
End Function
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
joboy,
Yes it is still doing the the same result.

It will work in the first cell,  but will not find consequent matches after that.
However, I still think your code is beneficial....

Thanks
fordraiders

0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
OK I've had a look at your original question (http://www.experts-exchange.com/Applications/MS_Office/Q_20779494.html) to try and better understand what you're trying to achieve.  Based on this I have now completely re-written my solution.  It comes in two parts, a completely new bit of code for searching the fldValues against the spreadsheet, and a revised CompareText function.

The new code will produce the following result from the example data below

In the Database:

fldValues
1-5K89-55
12445
12455
1a222
1DF59

In the Spreadsheet (MyNewData)

MATCHES      DESCRIPTION
      MOTOR,  NUMBER 1A222 PLASTIC FANS
      BEARINGS PART#12445, 1a222 and dog
      MOTORCYCLE PART 1DF59 , PART OF ENGINE
      CAR PARTS, TRUCK LATCH PART NUMBER 1-5K89-55, LISTED AS SEPARATE

Running the new FindMatches function produces the following result.

MATCHES              DESCRIPTION
1a222              MOTOR,  NUMBER 1A222 PLASTIC FANS
1a222, 12445  BEARINGS PART#12445, 1a222 and dog
1DF59              MOTORCYCLE PART 1DF59 , PART OF ENGINE
1-5K89-55        CAR PARTS, TRUCK LATCH PART NUMBER 1-5K89-55, LISTED AS SEPARATE



=================================================
Here's the new Find Matches code
=================================================

Public Sub FindMatches()
    Dim rngArea As Excel.Range
    Dim rngCell As Excel.Range
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim strMatches As String
   
    Set cn = New ADODB.Connection
    cn.Provider = "Microsoft.JET.OLEDB.4.0"
    cn.Open "J:\B&M Databases\Adhoc\Experts-Exchange.mdb"
   
    Set rs = New Recordset
    rs.Open "SELECT * From tblLook", cn, adOpenDynamic, adLockReadOnly
   
    Set rngArea = Sheets("MyNewData").Range("B2:B65000")
   
    For Each rngCell In rngArea
        If Len(rngCell) = 0 Then
            Exit For
        End If
       
        Do Until rs.EOF
            If CompareText(rs.Fields(0), rngCell, InnerLengthMatch, vbTextCompare) Then
                If Len(strMatches) > 0 Then strMatches = strMatches & ", "
                strMatches = strMatches & rs.Fields(0)
            End If
            rs.MoveNext
        Loop
        rngCell.Offset(, -1) = strMatches
        rs.MoveFirst
        strMatches = ""
    Next
   
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
    Set rngCell = Nothing
    Set rngArea = Nothing
End Sub

==========================================
And the revised CompareText function (the revision allows it to handle (-) symbols correctly)
==========================================
Public Function CompareText(ByVal String1 As String, ByVal String2 As String, _
 Optional Match As InStrPos = Anywhere, Optional Compare As VbCompareMethod) As Long
   Dim n As Long, n2 As Long
   Dim strSwitchBuf As String
   Dim strChunk As String
   
   If (Match And FullLengthMatch) = FullLengthMatch And Len(String1) <> Len(String2) Then
       n = 0
   Else
       'Place the strings in the correct comparative order (i.e. short compares to long)
       If Len(String2) > Len(String1) Then
           strSwitchBuf = String2
           String2 = String1
           String1 = strSwitchBuf
       End If
       'Check if string 1 exists in string 2
       n = InStr(1, String1, String2, Compare)
       
       If n > 0 Then
           If (Match And InnerLengthMatch) = InnerLengthMatch Then
               For n2 = n To Len(String1)
                   strChunk = strChunk + Mid(String1, n2, 1)
                   If n2 > 1 And n2 = n Then
                       If Asc(Mid(String1, n2 - 1, 1)) > 45 Then
                           n2 = InStr(n2 + 1, String1, String2, Compare) - 1
                           strChunk = ""
                           If n2 = -1 Then Exit For
                       End If
                   ElseIf n2 < Len(String1) Then
                       If Asc(Mid(String1, n2 + 1, 1)) < 45 Then Exit For
                   End If
               Next
               
               If Len(strChunk) <> Len(String2) Then
                   n = 0
               End If
           End If
           
           If (Match And BeginsWith) = BeginsWith And n > 1 Then
               n = 0
           ElseIf (Match And EndsWith) = EndsWith And n + Len(String2) - 1 < Len(String1) Then
               n = 0
           End If
       End If
   
   End If
   
   CompareText = n
End Function
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
o.k.,
Great support from both of you guys......

I'am going to give 500 apiece....


Is this o.k.?


I will have to repost a question to give to joboy. for 500

Thanks
fordraiders
0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
Thanks Fordraiders, very generous!!  Have we answered your question? or are you still experiencing problems?
0
 
LVL 24

Expert Comment

by:R_Rajesh
Comment Utility
Hey ! fordraiders,

Thanks :)
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
I actually have both codes working and doing different things now.
It was a great thread.
Thanks for all the help...

You guys have nailed this to the coffin. :-)


and this is not it.... I have some more updating for this routine..

fordraiders
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
JOBOY,
I have been playing around more with your last revised post.
How can I make this search now more wildcard oriented.?

Thanks
fordraiders
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
Joboy,
Nevermind...
I got it  

0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
Joboy,
What I meant was how do you do the combination ?

Match = Optional. Determines how the match between the range contents and the "What" value should be made. Can be BeginsWith, EndsWith,  AnyWhere, FullLengthMatch, InnerLengthMatch, or a combination of any.   <------??


Thanks
fordraiders
0
 
LVL 5

Expert Comment

by:joboy
Comment Utility
Fordraiders,

I'm just about to go to work, so will look at this later!
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
Rajesh,

This code seems to skip by row 2 and will not search the row
The searching starts on row 3...?


Thanks
fordraiders
0
 
LVL 24

Expert Comment

by:R_Rajesh
Comment Utility
Hi ford,

was out of town for the entire week. have you already solved the problem??
will look at it later in the afternoon and make a post :)
0
 
LVL 3

Author Comment

by:fordraiders
Comment Utility
No, I have not solved it yet...

Thanks
Hope you had a good trip....

0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Introduction Perhaps more familiar to developers who primarily use VBScript than to developers who tend to work only with Microsoft Office and Visual Basic for Applications (VBA), the Dictionary is a powerful and versatile class, and is useful …
No matter the version of Windows you are using, you may have some problems with Windows Search running too slow or possibly not running at all. Before jumping into how you can solve this issue, just know there are many other viable alternative deskt…
This video shows the viewer how to set up and create Footnotes in their document. Click on the References tab: Select "Insert Footnote": Type in desired text:
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now