Solved Find Single Words in Column that Contain Multiple Words

June 28, 2017 at 06:30:49
Specs: Windows 7
Below is the macro I am running which works great if the search words I am looking for match the entire contents in Column D of Sheet 1. However, I am hoping to find a match anywhere within the column. For example if I am looking for last name "Smith" and Column D contains "Michael Smith" my current macro would not find it. I am hoping to fix that so it would find it.

Basic setup of workbook:
1 - Sheet 1 Row 1 contains Column Headings.
2 - Sheet 2 is the destination sheet for the copied rows.
3 - You want the same Column Headings on Sheet 2 that are on Sheet 1.
4 - Sheet 3 Column A contains the list of Gene names to search for, starting in A2.

Macro I am running currently:

Option Explicit
Sub GeneFinder()
Dim srchLen, gName, nxtRw As Integer
Dim g As Range
'Clear Sheet 2 and Copy Column Headings
Sheets(2).Cells.ClearContents
Sheets(1).Rows(1).Copy Destination:=Sheets(2).Rows(1)
'Determine length of Search Column from Sheet3
srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
'Loop through list in Sheet3, Column A. As each value is
'found in Sheet1, Column E, copy it top the next row in Sheet2
With Sheets(1).Columns("E")
For gName = 2 To srchLen
Set g = .Find(Sheets(3).Range("A" & gName), lookat:=xlWhole)
If Not g Is Nothing Then
nxtRw = Sheets(2).Range("E" & Rows.Count).End(xlUp).Row + 1
g.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
End If
Next
End With
End Sub

Thank you in advance.


See More: Find Single Words in Column that Contain Multiple Words

Reply ↓  Report •

✔ Best Answer
July 11, 2017 at 16:49:19
For the following code, all I did was remove the section that searches for the first name. Basically, the code assumes that anything after the first space is the last name. There is virtually no way for the code to know whether names such as Christopher Van Trinkle mean:

    First               Last
Christopher         Van Trinkle

or

    First               Last
Christopher Van       Trinkle

or

    First       Middle       Last
Christopher      Van        Trinkle

Try this:

Option Explicit
Sub CopyNameRow()
Dim srchLen As Long
Dim lName As Integer, nxtRw As Integer
Dim l As Range
Dim lastName As String, firstAddress As String

'Clear Sheet 2 and Copy Column Headings
 Sheets(2).Cells.ClearContents
 Sheets(1).Rows(1).Copy Destination:=Sheets(2).Rows(1)
 
'Determine length of Search Column from Sheet3
   srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
   
'Loop through list in Sheet3, Column A. As each Last Name is
'Found in Sheet1, Column E, copy it to the next row in Sheet2

''Last Name Search
  With Sheets(1).Columns("E")
    For lName = 2 To srchLen
'Strip off first name and space
     lastName = Right(Sheets(3).Range("A" & lName), Len(Sheets(3).Range("A" & lName)) - _
                                                    InStr(Sheets(3).Range("A" & lName), " "))
      Set l = .Find(lastName, lookat:=xlPart)
        If Not l Is Nothing Then
        firstAddress = l.Address
'Repeat Search and Copy
        Do
           nxtRw = Sheets(2).Range("E" & Rows.Count).End(xlUp).Row + 1
            l.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
        Set l = .FindNext(l)
        Loop While Not l Is Nothing And l.Address <> firstAddress
      End If
    Next
  End With
  
'Remove Duplicates on Sheet 2
      Sheets(2).UsedRange.RemoveDuplicates Columns:=5, Header:=xlNo
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.



#1
June 28, 2017 at 07:22:42
You can just change xlWhole to xlPart and it will look for any permutation of the search string.

Set g = .Find(Sheets(3).Range("A" & gName), lookat:=xlPart)


Reply ↓  Report •

#2
June 28, 2017 at 08:03:40
First, a posting tip:

Please click on the blue line at the end of this post and read the instructions on how to post VBA code in this forum so that it is easier for us to read. Then edit/repost your code so that it looks similar to the example found via that link. Thanks!

As for your question...

While AWTL has offered a solution to your issue, please be aware that if you search for Smith, xlPart will not just return Micheal Smith, it will also return:

Goldsmith
Smithers
Verkensmithkoss
Smith-Calkins
Calkins-Smith

You can eliminate some of the mid-string (lowercase) smiths by adding MatchCase:=True, but that won't eliminate Smithers or the hyphenated Smiths.

There are ways around all of that, but since I assume that Smith isn't really your search term, I'll refrain from offering any suggestions until we have more details.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.

message edited by DerbyDad03


Reply ↓  Report •

#3
June 28, 2017 at 08:40:11
Awesome! It worked! Thanks Much

Reply ↓  Report •

Related Solutions

#4
June 28, 2017 at 09:04:14
Option Explicit
Sub GeneFinder()
Dim srchLen, gName, nxtRw As Integer
Dim g As Range
'Clear Sheet 2 and Copy Column Headings
 Sheets(2).Cells.ClearContents
 Sheets(1).Rows(1).Copy Destination:=Sheets(2).Rows(1)
'Determine length of Search Column from Sheet3
   srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
'Loop through list in Sheet3, Column A. As each value is
'found in Sheet1, Column E, copy it top the next row in Sheet2
  With Sheets(1).Columns("E")
    For gName = 2 To srchLen
      Set g = .Find(Sheets(3).Range("A" & gName), lookat:=xlPart)
        If Not g Is Nothing Then
          nxtRw = Sheets(2).Range("E" & Rows.Count).End(xlUp).Row + 1
          g.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
        End If
    Next
  End With
End Sub


Reply ↓  Report •

#5
June 28, 2017 at 09:06:18
I reposted vba with new format. Thanks!

I do like your suggestion of eliminating false positive "smiths". Let me know what I can do.

Thanks again.

message edited by BTan


Reply ↓  Report •

#6
June 28, 2017 at 11:26:54
For the VBA above, is there a way to have all findings copied over to sheet 2 and not just the 1st finding? What is happening now is if the code finds "Michael Smith" it will not also find/copy "Travis Smith".

Let me know if you need more info.
Thanks!


Reply ↓  Report •

#7
June 28, 2017 at 11:31:29
Well, as I mentioned, since I don't know exactly what you are searching for, it is hard for me to make firm suggestions.

If you actually want to search for <space>Smith<space>, then you could try this:

Set g = .Find (" " & Sheets(3).Range("A" & gName) & " ", lookat:=xlPart, MatchCase:=True)

If the last name will always be at the end of the cell, e.g. <space>Smith, then try this:

Set g = .Find (" " & Sheets(3).Range("A" & gName), lookat:=xlPart, MatchCase:=True)

All I'm doing is concatenating a hard space " " before and after the cell reference that VBA is using.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#8
June 28, 2017 at 12:39:16
DerbyDad:

I am searching for names listed in Sheet 3, Column A Contain Full Names such as below.

Stephen Slawter
Subhi Stanley
Summer Parker
Sylvia Tanner
Tadd Chaseman
Tara Peyton
Thamret Daiser
Thomas Withersonny
Timesly Basil
Michael Smith
Travis Smith


I would like the code to capture any match (first or last name) from the above that are within a string in Sheet 1, Column E and copy all finding to Sheet 2.

As I mentioned previously: if the code finds "Michael Smith" it will not also find/copy "Travis Smith".

I hope that is more clear.

Thanks

message edited by BTan


Reply ↓  Report •

#9
June 28, 2017 at 13:48:43
Why did you start a separate thread? I have deleted it since it is merely an expansion of your question in this thread. There is no need to start from scratch.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#10
June 28, 2017 at 14:00:24
Apologies, I realized that this code was not was I was looking for so thought it would be cleaner to start a new one. Everything above was not returning all matches of either first or last name and was only returning the first match it finds.

I have a list of Full Names in Sheet 3, Column A
For example:

Stephen Slawter
Subhi Stanley
Summer Parker


I need to search Sheet 1, Column E string and find ALL matches (first or last name) and have all the rows copied to sheet 2. Headers are same in sheet 2 if that helps.

Sheet 1, Column E String could look like:

Stephen Slawter Trust
Stephen Williams
Mike Slawter Industries

I would want all 3 rows copied to Sheet 2 because either the first name or last name is a match.

Thanks


Reply ↓  Report •

#11
June 28, 2017 at 18:35:32
Looping the code to find all occurrences of a given word is fairly common and fairly simple. You can use the VBA .FindNext method. Basically VBA stores the Address of the first match and keeps "finding" the string until that Address is found again. Once it finds the first Address a second time, it knows that it has found all occurrences.

  With Sheets(1).Columns("E")
    For gName = 2 To srchLen
      Set g = .Find(Sheets(3).Range("A" & gName), lookat:=xlPart)
        If Not g Is Nothing Then
        firstAddress = g.Address
        Do
           nxtRw = Sheets(2).Range("E" & Rows.Count).End(xlUp).Row + 1
            g.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
        Set g = .FindNext(g)
        Loop While Not g Is Nothing And g.Address <> firstAddress
      End If
    Next
  End With

That's the easy part

Next, we already know that the code can find a partial match, e.g. Stephen by using xlPart.

That's the other easy part.

The hard part is passing your search strings from Sheet 3 to VBA. VBA can't find Stephen on Sheet1 if the contents of the cell on Sheet3 is Stephen Slawter. The xlPart argument only works on the "I found it" side, not on the "look for it". In other words, when you tell VBA to use the contents of a cell as the search string, it is going to use the entire contents.

What you need to do is separate the data on Sheet 3 into multiple columns and search for each individual string. However, that is going to present a problem.

Let's say Sheet 3 now looks like this:

        A            B
1    Stephen      Slawter
2    Subhi        Stanley
3    Summer       Parker

When you run the code and it searches for Stephen, it's going to copy the rows containing:

Stephen Slawter Trust
Stephen Williams

No problem.

But when the code searches for Slawter, it is going to copy the rows containing:

Stephen Slawter Trust
Mike Slawter Industries

There's the problem. You now have 2 copies of the row containing Stephen Slawter Trust.

That means we have to do one of two things. We either have to add code to delete the duplicates or we need to add code that checks the list on Sheet 2 to see if the newly found string already exists. If it does, don't copy/paste it. Both tasks are doable, it just takes more code.

I'll work on it, but I can't say when it will be complete. If I don't get it done tomorrow (and I don't think I will), not much will happen for a week or so. I'm not going to have access to Excel for at least 5 days and after that I'll need to catch up on real work, not this volunteer stuff.

If you can be patient, we'll eventually get you to where you need to go.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#12
June 29, 2017 at 05:53:53
Thanks! Appreciate the help.

Reply ↓  Report •

#13
June 29, 2017 at 08:03:37
Try the following macro.

What I have done is added the code required to:

1 - Extract the First names from the list on Sheet 3
2 - Search for all occurrences of the First name and Copy the found rows to Sheet 2
3 - Extract the Last names from the list on Sheet 3
4 - Search for all occurrences of the Last name and Copy the found rows to Sheet 2
5 - Remove the duplicate Rows on Sheet2 based on Column E

Some caveats:

1 - The code was written based on the example list of names that you provided. Since each name contained only a First name and a Last name, that is what the code can handle. If you have names such as Stephen Thomas Williams, the code will not work. That is the reason that you need to be extremely specific when you give us your requirements. We can't see your data from where we are sitting, so we can only provide solutions to the requirements we know about. Adding requirements after a solution is offered can often be a waste of our time since we often have to re-write major portions of the code or bolt on code sections, resulting in inefficient code.

2 - The removal of the duplicates on Sheet 2 is based solely on the contents of Sheet 2 Column E. Based on your example data, the Row for Stephen Slawter Trust will be copied twice - once for Stephen, and once for Slawter. Eventually, all but one of the Stephen Slawter Trust rows will be deleted. Please Note: If your Sheet 1 data contains more than one Row with Stephen Slawter Trust in Column E but different data in other columns, you are going to lose all but one of the Rows on Sheet 2. If that is going to be an issue, then once again, you need to give us your full requirements.

Here is the code that meets your requirements as currently stated

Option Explicit
Sub CopyNameRow()
Dim srchLen As Long
Dim fName As Integer, lName As Integer, nxtRw As Integer
Dim f As Range, l As Range
Dim firstName As String, lastName As String, firstAddress As String

'Clear Sheet 2 and Copy Column Headings
 Sheets(2).Cells.ClearContents
 Sheets(1).Rows(1).Copy Destination:=Sheets(2).Rows(1)
 
'Determine length of Search Column from Sheet3
   srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
   
'Loop through list in Sheet3, Column A. As each Partial Name is
'Found in Sheet1, Column E, copy it to the next row in Sheet2

''First Name Search
  With Sheets(1).Columns("E")
    For fName = 2 To srchLen
'Strip off space and last name
     firstName = Left(Sheets(3).Range("A" & fName), InStr(Sheets(3).Range("A" & fName), " ") - 1)
      Set f = .Find(firstName, lookat:=xlPart)
        If Not f Is Nothing Then
        firstAddress = f.Address
'Repeat Search and Copy
        Do
           nxtRw = Sheets(2).Range("E" & Rows.Count).End(xlUp).Row + 1
            f.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
        Set f = .FindNext(f)
        Loop While Not f Is Nothing And f.Address <> firstAddress
      End If
    Next
  End With

''Last Name Search
  With Sheets(1).Columns("E")
    For lName = 2 To srchLen
'Strip off first name and space
     lastName = Right(Sheets(3).Range("A" & lName), Len(Sheets(3).Range("A" & lName)) - _
                                                    InStr(Sheets(3).Range("A" & lName), " "))
      Set l = .Find(lastName, lookat:=xlPart)
        If Not l Is Nothing Then
        firstAddress = l.Address
'Repeat Search and Copy
        Do
           nxtRw = Sheets(2).Range("E" & Rows.Count).End(xlUp).Row + 1
            l.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
        Set l = .FindNext(l)
        Loop While Not l Is Nothing And l.Address <> firstAddress
      End If
    Next
  End With
  
'Remove Duplicates on Sheet 2
      Sheets(2).UsedRange.RemoveDuplicates Columns:=5, Header:=xlNo
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#14
June 30, 2017 at 09:32:06
Thanks! I understand that giving you as much detail as possible so that you can provide best solution is the goal. I do appreciate you working with me on this and for your understanding that due to confidentiality reasons I cannot just copy the data I am working with into this thread. That said, we are almost there. A couple of more things you should be aware of:

There are names on Sheet 3 that have more than just First/Last and there are a few hyphenated names as well. I don't think it matters but some names are all Caps and some are a mix of Caps and lower case letters. Couple of examples:

LORENA DE LA MARTINEZ
Kelle Jackson-Kirshner
John Hoover-Booker
Christopher Van Trinkle

Lastly: After seeing the results of the most recent macro, I hope to only search by last names in Column A, Sheet 3. Searching for both first and last produced too many positive outcomes for what I am trying to accomplish.

Taking into account the names with more than just first/last and the hyphenated names, here is what I think will be ultimate solution:

1 - Extract the LAST names from the list on Sheet 3
2 - Search for all occurrences of the LAST name and Copy the found rows to Sheet 2
3 - Remove the duplicate Rows on Sheet2 based on Column E

If the hyphenated/longer names prove to be too difficult to code for, than don't worry too much about those as I could manually research them since there are so few in my workbook.

Thanks again and have a great weekend!

message edited by BTan


Reply ↓  Report •

#15
July 10, 2017 at 13:20:37
Still hoping to get some assistance to close this one out. Any help on my last post is greatly appreciated.
Thank you in advance!

Reply ↓  Report •

#16
July 11, 2017 at 16:49:19
✔ Best Answer
For the following code, all I did was remove the section that searches for the first name. Basically, the code assumes that anything after the first space is the last name. There is virtually no way for the code to know whether names such as Christopher Van Trinkle mean:

    First               Last
Christopher         Van Trinkle

or

    First               Last
Christopher Van       Trinkle

or

    First       Middle       Last
Christopher      Van        Trinkle

Try this:

Option Explicit
Sub CopyNameRow()
Dim srchLen As Long
Dim lName As Integer, nxtRw As Integer
Dim l As Range
Dim lastName As String, firstAddress As String

'Clear Sheet 2 and Copy Column Headings
 Sheets(2).Cells.ClearContents
 Sheets(1).Rows(1).Copy Destination:=Sheets(2).Rows(1)
 
'Determine length of Search Column from Sheet3
   srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
   
'Loop through list in Sheet3, Column A. As each Last Name is
'Found in Sheet1, Column E, copy it to the next row in Sheet2

''Last Name Search
  With Sheets(1).Columns("E")
    For lName = 2 To srchLen
'Strip off first name and space
     lastName = Right(Sheets(3).Range("A" & lName), Len(Sheets(3).Range("A" & lName)) - _
                                                    InStr(Sheets(3).Range("A" & lName), " "))
      Set l = .Find(lastName, lookat:=xlPart)
        If Not l Is Nothing Then
        firstAddress = l.Address
'Repeat Search and Copy
        Do
           nxtRw = Sheets(2).Range("E" & Rows.Count).End(xlUp).Row + 1
            l.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
        Set l = .FindNext(l)
        Loop While Not l Is Nothing And l.Address <> firstAddress
      End If
    Next
  End With
  
'Remove Duplicates on Sheet 2
      Sheets(2).UsedRange.RemoveDuplicates Columns:=5, Header:=xlNo
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Reply ↓  Report •

#17
July 12, 2017 at 08:18:35
Thank you, this works perfectly!

Reply ↓  Report •

Ask Question