Solved

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

Posted on 2003-10-30
30
392 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
ID: 9649977
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
ID: 9650025
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
ID: 9650211
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
Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
LVL 5

Expert Comment

by:joboy
ID: 9650244
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
ID: 9650346
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
ID: 9650487
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
ID: 9650619
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
ID: 9650643
>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
ID: 9650748
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
ID: 9650826
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
ID: 9650909
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
ID: 9651015
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
ID: 9651031
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
ID: 9651034
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
ID: 9651093
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
 
LVL 3

Author Comment

by:fordraiders
ID: 9651427
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
ID: 9651451
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
ID: 9651555
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
ID: 9651938
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
ID: 9653833
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
ID: 9656423
Thanks Fordraiders, very generous!!  Have we answered your question? or are you still experiencing problems?
0
 
LVL 24

Expert Comment

by:R_Rajesh
ID: 9657720
Hey ! fordraiders,

Thanks :)
0
 
LVL 3

Author Comment

by:fordraiders
ID: 9657969
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
ID: 9696868
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
ID: 9696876
Joboy,
Nevermind...
I got it  

0
 
LVL 3

Author Comment

by:fordraiders
ID: 9696894
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
ID: 9699789
Fordraiders,

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

Author Comment

by:fordraiders
ID: 9780821
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
ID: 9792694
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
ID: 9794981
No, I have not solved it yet...

Thanks
Hope you had a good trip....

0

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Some time ago I was asked to create a VBA function that would calculate a check digit for an input number, using the following procedure: First, sum up all the individual digits in the number If that sum value has more than one digit, then sum up …
Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

860 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