asked on

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?

Haris Dulic

Can you post sample data and desired output for better solution

dcastronw

ASKER

Sorry for the delay. I was driving home. I will within the hour ...hoping you still available.

dcastronw

ASKER

Hi Haris, Here is an example.
Sample.xlsx

Martin Liss

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.

dcastronw

ASKER

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

dcastronw

ASKER

sorry, please disregard the part about putting it the name/title into separate cell (same row)

Martin Liss

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?

dcastronw

ASKER

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?

Martin Liss

I'm having a problem with a simple Find. I'll get back to you.

ASKER CERTIFIED SOLUTION

Martin Liss

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

dcastronw

ASKER

Thank you! About to leave dinner table shortly and will try it. Thanks so much! I will feedback asap.

dcastronw

ASKER

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!

dcastronw

ASKER

I truly appreciate all of this code to solve my request.

Martin Liss

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.

dcastronw

ASKER

I appreciate it. Enjoy!

Martin Liss

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

dcastronw

ASKER

Thank you MartinLiss!
Sample.xlsm

Martin Liss

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

dcastronw

ASKER

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.

Martin Liss

Can you create a workbook that contains the row before the problem row and the problem row both with obfuscated data?

dcastronw

ASKER

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.

Martin Liss

Blank rows anywhere in sheet2 will not affect the output.

dcastronw

ASKER

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

Martin Liss

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.

dcastronw

ASKER

Yes please. Thank you!

Martin Liss

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.

Martin Liss

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