Solved

VBA for Lookup, Search etc

Posted on 2014-11-12
27
202 Views
Last Modified: 2014-11-16
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?
0
Comment
Question by:dcastronw
  • 14
  • 12
27 Comments
 
LVL 15

Expert Comment

by:Haris Djulic
ID: 40438733
Can you post sample data and desired output for better solution
0
 

Author Comment

by:dcastronw
ID: 40438898
Sorry for the delay. I was driving home. I will within the hour ...hoping you still available.
0
 

Author Comment

by:dcastronw
ID: 40438921
Hi Haris, Here is an example.
Sample.xlsx
0
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40444860
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
 

Author Comment

by:dcastronw
ID: 40444915
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
 

Author Comment

by:dcastronw
ID: 40444916
sorry, please disregard the part about putting it the name/title into separate cell (same row)
0
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40444953
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
 

Author Comment

by:dcastronw
ID: 40444976
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
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40445022
I'm having a problem with a simple Find. I'll get back to you.
0
 
LVL 45

Accepted Solution

by:
Martin Liss earned 500 total points
ID: 40445046
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
 

Author Comment

by:dcastronw
ID: 40445048
Thank you!  About to leave dinner table shortly and will try it. Thanks so much! I will feedback asap.
0
 

Author Comment

by:dcastronw
ID: 40445134
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
 

Author Closing Comment

by:dcastronw
ID: 40445135
I truly appreciate all of this code to solve my request.
0
Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

 
LVL 45

Expert Comment

by:Martin Liss
ID: 40445142
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
 

Author Comment

by:dcastronw
ID: 40445146
I appreciate it. Enjoy!
0
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40445177
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
 

Author Comment

by:dcastronw
ID: 40445186
Thank you MartinLiss!
Sample.xlsm
0
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40445203
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
 

Author Comment

by:dcastronw
ID: 40445208
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
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40445215
Can you create a workbook that contains the row before the problem row and the problem row both with obfuscated data?
0
 

Author Comment

by:dcastronw
ID: 40445222
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
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40445909
Blank rows anywhere in sheet2 will not affect the output.
0
 

Author Comment

by:dcastronw
ID: 40445962
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
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40445998
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
 

Author Comment

by:dcastronw
ID: 40446010
Yes please. Thank you!
0
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40446145
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
 
LVL 45

Expert Comment

by:Martin Liss
ID: 40446165
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

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Photo Albums in PowerPoint Photo Albums are a very useful tool in PowerPoint and allow you quickly add a large number of images. The images can be formatted in a variety of ways so that you are able to create a professional looking presentation v…
As freelancing is becoming more and more common in the tech industry, certain obstacles are proving to be a challenge to those who are used to more traditional, structured employment. This article is meant to help identify such obstacles and offer a…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
XMind Plus helps organize all details/aspects of any project from large to small in an orderly and concise manner. If you are working on a complex project, use this micro tutorial to show you how to make a basic flow chart. The software is free when…

707 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now