Excel module: Mark records if it contains names out of another list

[johan]

Hello,

I've got an spreadsheet with several columns. The datafields of it are
filled with a lot of text. A part of the text could be one or more of
the people that are linked to my group. I'v got a separate list with
the names of those people with in the next column their company nr.
(for example: McGregor UTP135)

In detail:
Sheet 1, Column B, C and D is filled with text and perhaps one or more
of the names of my people is a part of it.
Sheet 2, Column A is the persons name and Column B is the company nr.

What I like to have;
A module which looks in sheet 1 if the name of a person (from sheet 2)
is filled in in one of the columns B,C,D per record. If so, then the
module has to set the persons name in column E and thecompany nr in
column F.
The module has to do this for each name on the list of sheet 2.

remarks:
It could be possible that more then one person of the list in sheet 2
is filled in in the same record of sheet 1.
I think that its to difficult (?) to set in the same record of column
E/F also the other name/companynr of the other people. No problem if
so, but....... it should be nice .
Another solution could be that the module registered in column G the
totalnumber of found people but registered in column E/F only the
first one that were found. (for example: McGregor UTP135 3).
Then I know that I have to check also in detail the marked record for
the other names.

If somebody can help me out (happy).

regards,
Johan.

 

[Don Guillett]

if desired, send your file to dguillett1 @gmail.com with this msg ,
examples.

 

[Tim Williams]

Here's a possible solution:


Sub DoSearch()

Const COL_NAME As Integer = 5

Dim rngContent As Range, rngNames As Range
Dim c As Range, bFound As Boolean, rw As Range
Dim rngN As Range, sep As String

'adjust ranges to suit....
Set rngContent = ThisWorkbook.Sheets("Sheet1").Range("B2100")
Set rngNames = ThisWorkbook.Sheets("Sheet2").Range("A2:A100")

For Each rw In rngContent.Rows
For Each rngN In rngNames.Cells
For Each c In rw.Cells
If c.Value <> "" And rngN.Value <> "" And _
InStr(c.Value, rngN.Value) > 0 Then

sep = ""
With rngContent.Parent.Cells(c.Row, COL_NAME)
If Len(.Value) > 0 Then sep = Chr(10)
.Value = .Value & sep & rngN.Value
.Offset(0, 1).Value = .Offset(0, 1).Value & _
sep & rngN.Offset(0, 1).Value
End With
Exit For 'stop checking once name is found

End If
Next c
Next rngN
Next rw

End Sub


Tim

 

[Tim Williams]

Bonus: add this in just above `sep="" ` and it will highlight the
found name in the text being searched.


'hilite the found name
c.Characters(Start:=InStr(c.Value, rngN.Value), _
Length:=Len(rngN.Value)).Font.Color = vbRed


Tim

 

[johan]

Don,

Thanks for the solution you had send to me (and which is included
below).
It works as needed
Regards, Johan.


================
'========
Option Explicit
Sub GetDataSAS()
Dim c As Range
Dim mf As Range
Dim i As Long

Application.ScreenUpdating = False
Cells(2, "e").Resize(100, 3).ClearContents

For Each c In Sheets("sheet2").Range("b2:b5")
For i = 2 To 4

Set mf = Columns(i).Find(What:=c, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not mf Is Nothing Then
Cells(mf.Row, "f") = Cells(mf.Row, "f") & " " & c
Cells(mf.Row, "e") = Cells(mf.Row, "e") & " " & c.Offset(, -1)
Cells(mf.Row, "g") = Cells(mf.Row, "g") + 1
End If
Next i
Next c
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
'========