VBA for Lookup, Search etc

I have sheet 1 column A with names, sheet 1 column B with name, title.  On sheet 2, column 1 contains an email header such as name <email address>; another name <email address>.  I have been searching a combination of code for hours and possibly not looking up using the correct search terms.  Can anyone guide me to some vba script for excel that will take the list of names in sheet 1, when they appear in sheet 2 (name <email address>), replace that name <email address> with the name, title from sheet 1?
dcastronwAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
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.

Haris DulicIT ArchitectCommented:
Can you post sample data and desired output for better solution
0
dcastronwAuthor Commented:
Sorry for the delay. I was driving home. I will within the hour ...hoping you still available.
0
dcastronwAuthor Commented:
Hi Haris, Here is an example.
Sample.xlsx
0
CompTIA Security+

Learn the essential functions of CompTIA Security+, which establishes the core knowledge required of any cybersecurity role and leads professionals into intermediate-level cybersecurity jobs.

Martin LissOlder than dirtCommented:
In your posted workbook, the "Titles" sheet which is the sheet I assume you mean when you say "sheet2", doesn't match your description. On that sheet I see Names and Titles but no email address.
0
dcastronwAuthor Commented:
Hi MartinLiss.  Sorry, I created that sample after a very long day.  I revised the sample and attached it.  I was thinking, does it make sense/work to put the names and title in an array, then search the sheet2 for names ... then put that name/title into a totally different cell (same row).  I am not sure if I am thinking about it correctly.  If I could search for that name, when it is found, select and delete everything before the semicolon (which would be the name and email address), and replace it with the name/title.
Sample.xlsx
0
dcastronwAuthor Commented:
sorry, please disregard the part about putting it the name/title into separate cell (same row)
0
Martin LissOlder than dirtCommented:
Is sheet2 the sheet that drives the process? In other words do you want the Ideal results sheet to reflect what's on sheet2, using the Title(s) from sheet1? Will there always be a CC on sheet2?
0
dcastronwAuthor Commented:
When you say 'refect whats on sheet2' ...The ideal result will still the columns being From, To, CC with multiple names in the To and CC fields.  The structure should remain how it is on sheet2, but I will need the name with title (having replaced the email address, still separated by semicolons of multiple in the To or CC.  I get an export with the From, To and CC.  And then I get the information with the titles separately.  I want to know who these records (originally email messages) are from, to and copied, but my end result doesn't care about the email addresses, instead the titles.  Is this what you mean by sheet2 'driving' the process?
0
Martin LissOlder than dirtCommented:
I'm having a problem with a simple Find. I'll get back to you.
0
Martin LissOlder than dirtCommented:
Add these two macros and run the first one. It assumes a sheet named "Results" (which I created for my testing) but that's easily changed (see line 13). Note that lines 29 and 43 contain "& vbCrLf" which results in multiple names being stacked in the cell. If you don't want that then just remove that part of the lines.

Sub CreateResults()
Dim lngLastRow As Long
Dim lngRow As Long
Dim lngPart As Long
Dim sht2 As Worksheet
Dim shtr As Worksheet
Dim strParts() As String
Dim intPos As Integer
Dim lngNewRow As Long
Dim strPerson As String

Set sht2 = Sheets("sheet2")
Set shtr = Sheets("Results")

lngLastRow = sht2.Range("A1048576").End(xlUp).Row

For lngRow = 2 To lngLastRow
    lngNewRow = shtr.UsedRange.Rows.Count + 1
    ' "To" processing
    strParts = Split(sht2.Cells(lngRow, 1), ";")
    For lngPart = 0 To UBound(strParts)
        intPos = InStr(strParts(lngPart), "<")
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                .Cells(lngNewRow, 1) = strPerson & ", " & Title(strPerson)
            Else
                .Cells(lngNewRow, 1) = _
                .Cells(lngNewRow, 1) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
    ' "CC" processing
    strParts = Split(sht2.Cells(lngRow, 2), ";")
    For lngPart = 0 To UBound(strParts)
        intPos = InStr(strParts(lngPart), "<")
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                .Cells(lngNewRow, 2) = strPerson & ", " & Title(strPerson)
            Else
                .Cells(lngNewRow, 2) = _
                .Cells(lngNewRow, 2) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
Next
End Sub
Function Title(strName As String) As String
    Dim rng As Range
    
    With Sheets("Sheet1").Range("A:A")
        Set rng = .Find(What:=strName, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                Title = rng.Offset(0, 1)
            Else
                MsgBox strName & " Not found on sheet1"
                Title = "Unknown Title"
            End If
            End With

End Function

Open in new window

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
dcastronwAuthor Commented:
Thank you!  About to leave dinner table shortly and will try it. Thanks so much! I will feedback asap.
0
dcastronwAuthor Commented:
MartinLiss, I realize that I need to polish up on some of these other excel/vba properties.  I added another row to sheet2.  And now it is stopping after processing the first row of sheet2, highlight/debug on line 23 ("strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))").  I realize because I am not completetly understand lines above, I can't debug it myself or ask a next question.  I am polishing up on understanding everything you provided, so that I can figure out what is wrong or what to ask next.    The first row of the results came out exactly how I wanted, but not sure why it won't continue onto the next line.  I am pretty sure you gave me is what I need.  I just need to understand myself.  Thank you so much!
0
dcastronwAuthor Commented:
I truly appreciate all of this code to solve my request.
0
Martin LissOlder than dirtCommented:
I'm going out to dinner with the wife. When I get back I'll give you a copy of the code with full explanatory comments.
0
dcastronwAuthor Commented:
I appreciate it. Enjoy!
0
Martin LissOlder than dirtCommented:
Post the workbook with the new sheet2 row because i did the same and it worked, so it must be a problem the data. In any case here's the documented code.

Sub CreateResults()
Dim lngLastRow As Long
Dim lngRow As Long
Dim lngPart As Long
Dim sht2 As Worksheet
Dim shtr As Worksheet
Dim strParts() As String
Dim intPos As Integer
Dim lngNewRow As Long
Dim strPerson As String

Set sht2 = Sheets("sheet2")
Set shtr = Sheets("Results")

' Find the last row on sheet2
lngLastRow = sht2.Range("A1048576").End(xlUp).Row

' loop through the sheet2 rows
For lngRow = 2 To lngLastRow
    ' Calculate the Results sheet row number for the new output. It is the last used row on the sheet plus 1
    lngNewRow = shtr.UsedRange.Rows.Count + 1
    ' "To" processing
    ' Break apart the data in the column "A" (represented by the "1") row at the ";" character
    strParts = Split(sht2.Cells(lngRow, 1), ";")
    ' Loop through the broken-up parts. If there are 2 parts, Ubound will be 1 since the count starts at 0.
    For lngPart = 0 To UBound(strParts)
        ' Find the character postion of the "<"
        intPos = InStr(strParts(lngPart), "<")
        ' Isolate the name
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                ' It's the first part so just place the name and title in the cell
                .Cells(lngNewRow, 1) = strPerson & ", " & Title(strPerson)
            Else
                ' It's subsequent parts so we need to add a ":" at the end of what's already
                ' there and then add the next name and title
                .Cells(lngNewRow, 1) = _
                .Cells(lngNewRow, 1) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
    ' "CC" processing. Same as above except that we use column B instead of A
    strParts = Split(sht2.Cells(lngRow, 2), ";")
    For lngPart = 0 To UBound(strParts)
        intPos = InStr(strParts(lngPart), "<")
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                .Cells(lngNewRow, 2) = strPerson & ", " & Title(strPerson)
            Else
                .Cells(lngNewRow, 2) = _
                .Cells(lngNewRow, 2) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
Next
End Sub

Open in new window

0
dcastronwAuthor Commented:
Thank you MartinLiss!
Sample.xlsm
0
Martin LissOlder than dirtCommented:
Here's an updated macro.

Sub CreateResults()
Dim lngLastRow As Long
Dim lngRow As Long
Dim lngPart As Long
Dim sht2 As Worksheet
Dim shtr As Worksheet
Dim strParts() As String
Dim intPos As Integer
Dim lngNewRow As Long
Dim strPerson As String

Set sht2 = Sheets("sheet2")
Set shtr = Sheets("Results")

' Find the last row on sheet2
lngLastRow = sht2.Range("A1048576").End(xlUp).Row

' loop through the sheet2 rows
For lngRow = 2 To lngLastRow
    ' Calculate the Results sheet row number for the new output. It is the last used row on the sheet plus 1
    lngNewRow = shtr.Range("A1048576").End(xlUp).Row + 1
    ' "To" processing
    ' Break apart the data in the column "A" (represented by the "1") row at the ";" character
    strParts = Split(sht2.Cells(lngRow, 1), ";")
    ' Loop through the broken-up parts. If there are 2 parts, Ubound will be 1 since the count starts at 0.
    For lngPart = 0 To UBound(strParts)
        ' Find the character postion of the "<"
        intPos = InStr(strParts(lngPart), "<")
        If intPos = 0 Then
            ' There's no "<" in the email address so look for "["
            intPos = InStr(strParts(lngPart), "[")
        End If
        ' Isolate the name
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                ' It's the first part so just place the name and title in the cell
                .Cells(lngNewRow, 1) = strPerson & ", " & Title(strPerson)
            Else
                ' It's subsequent parts so we need to add a ":" at the end of what's already
                ' there and then add the next name and title
                .Cells(lngNewRow, 1) = _
                .Cells(lngNewRow, 1) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
    ' "CC" processing. Same as above except that we use column B instead of A
    strParts = Split(sht2.Cells(lngRow, 2), ";")
    For lngPart = 0 To UBound(strParts)
        intPos = InStr(strParts(lngPart), "<")
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                .Cells(lngNewRow, 2) = strPerson & ", " & Title(strPerson)
            Else
                .Cells(lngNewRow, 2) = _
                .Cells(lngNewRow, 2) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
Next
End Sub

Open in new window

0
dcastronwAuthor Commented:
Works on my sample.  Thank you so much!  Unfortunately, I can't send my actual log ...but now I have to figure out why I get an debug stop on the same line, with no results, on my real data.
0
Martin LissOlder than dirtCommented:
Can you create a workbook that contains the row before the problem row and the problem row both with obfuscated data?
0
dcastronwAuthor Commented:
Ok MartinLiss! Thanks for your continued helping me with this. I will in the morning.  Now that you ask ...my first row doesnt have any email records. Which is what my typical data could be.  Thanks again.
0
Martin LissOlder than dirtCommented:
Blank rows anywhere in sheet2 will not affect the output.
0
dcastronwAuthor Commented:
Sorry for the delay MartinLiss.  I don't have blank cells but I do have some entries in sheet2 that nothing like it exist in sheet1.
ASample.xlsm
0
Martin LissOlder than dirtCommented:
In your original posting, sheet2 contains "To" in column A and "CC" in column B. In the new workbook, similar data is in columns D and E and unless I hear differently I'll assume you want me to use those columns instead and ignore columns A and B.
0
dcastronwAuthor Commented:
Yes please. Thank you!
0
Martin LissOlder than dirtCommented:
Here are the modified macros.
Sub CreateResults()
Dim lngLastRow As Long
Dim lngRow As Long
Dim lngPart As Long
Dim sht2 As Worksheet
Dim shtr As Worksheet
Dim strParts() As String
Dim intPos As Integer
Dim lngNewRow As Long
Dim strPerson As String

Set sht2 = Sheets("sheet2")
Set shtr = Sheets("Results")

' Find the last row on sheet2
lngLastRow = sht2.Range("C1048576").End(xlUp).Row

' loop through the sheet2 rows
For lngRow = 2 To lngLastRow
    ' Calculate the Results sheet row number for the new output. It is the last used row on the sheet plus 1
    lngNewRow = shtr.Range("A1048576").End(xlUp).Row + 1
    ' "To" processing
    ' Break apart the data in the column "C" (represented by the "1") row at the ";" character
    strParts = Split(sht2.Cells(lngRow, 3), ";")
    ' Loop through the broken-up parts. If there are 2 parts, Ubound will be 1 since the count starts at 0.
    For lngPart = 0 To UBound(strParts)
        ' Find the character postion of the "<"
        intPos = InStr(strParts(lngPart), "<")
        If intPos = 0 Then
            ' There's no "<" in the email address so look for "["
            intPos = InStr(strParts(lngPart), "[")
        End If
        If intPos = 0 Then
            ' Assume that only the name is in the cell and so "fudge" the position so
            ' the code will work the same way as when there is a < or a [
            intPos = Len(strParts(lngPart)) + 1
        End If
        
        ' Isolate the name
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                ' It's the first part so just place the name and title in the cell
                .Cells(lngNewRow, 1) = strPerson & ", " & Title(strPerson)
            Else
                ' It's subsequent parts so we need to add a ":" at the end of what's already
                ' there and then add the next name and title
                .Cells(lngNewRow, 1) = _
                .Cells(lngNewRow, 1) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
    ' "CC" processing. Same as above except that we use column B instead of A
    strParts = Split(sht2.Cells(lngRow, 4), ";")
    For lngPart = 0 To UBound(strParts)
        intPos = InStr(strParts(lngPart), "<")
        strPerson = Trim(Mid$(strParts(lngPart), 1, intPos - 1))
        With shtr
            If lngPart = 0 Then
                .Cells(lngNewRow, 2) = strPerson & ", " & Title(strPerson)
            Else
                .Cells(lngNewRow, 2) = _
                .Cells(lngNewRow, 2) & "; " & vbCrLf & strPerson & ", " & Title(strPerson)
            End If
        End With
    Next
Next
End Sub

Open in new window

In this one I commented out what otherwise would be a repetitious message when using the supplied workbook. If in real life the absence of a Title associated with a name were a rare condition, I would suggest uncommenting the line.
Function Title(strName As String) As String
    Dim rng As Range
    
    With Sheets("Sheet1").Range("A:A")
        Set rng = .Find(What:=strName, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not rng Is Nothing Then
                Title = rng.Offset(0, 1)
            Else
                'MsgBox strName & " Not found on sheet1"
                Title = "Unknown Title"
            End If
            End With

End Function

Open in new window


BTW, I see that you have stored the CreateResults and Tile macros in separate modules. There's no harm done but they can both be in the same module.
0
Martin LissOlder than dirtCommented:
Should this be our last interaction in this thread I just want to say in reply to your thanks that you're welcome and I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2014
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
Office Productivity

From novice to tech pro — start learning today.