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

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
 
LVL 3
FordraidersAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

joboyCommented:
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
R_RajeshCommented:
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
FordraidersAuthor Commented:
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
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

joboyCommented:
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
FordraidersAuthor Commented:
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
joboyCommented:
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
FordraidersAuthor Commented:
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
joboyCommented:
>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
R_RajeshCommented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FordraidersAuthor Commented:
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
FordraidersAuthor Commented:
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
R_RajeshCommented:
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
joboyCommented:
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
R_RajeshCommented:
sorry did you say column b of sheet 2 i thought we were pasting the database values to column a of sheet2 ?
0
FordraidersAuthor Commented:
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
FordraidersAuthor Commented:
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
joboyCommented:
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
FordraidersAuthor Commented:
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
joboyCommented:
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
FordraidersAuthor Commented:
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
joboyCommented:
Thanks Fordraiders, very generous!!  Have we answered your question? or are you still experiencing problems?
0
R_RajeshCommented:
Hey ! fordraiders,

Thanks :)
0
FordraidersAuthor Commented:
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
FordraidersAuthor Commented:
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
FordraidersAuthor Commented:
Joboy,
Nevermind...
I got it  

0
FordraidersAuthor Commented:
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
joboyCommented:
Fordraiders,

I'm just about to go to work, so will look at this later!
0
FordraidersAuthor Commented:
Rajesh,

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


Thanks
fordraiders
0
R_RajeshCommented:
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
FordraidersAuthor Commented:
No, I have not solved it yet...

Thanks
Hope you had a good trip....

0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.