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
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
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
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
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
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Excel Array formula Help | 11 | 54 | |
Excel 2016 - Row 1 missing | 5 | 68 | |
Earnings Spreadsheet in Excel | 3 | 65 | |
How do I convert xps to .doc or PDF files? | 5 | 49 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
19 Experts available now in Live!