Dim myText As Variant
Dim firstRow As Long
Dim lastRow As Long
Dim targetRowCounter
Dim twoNames As Boolean
Dim myData(1 To 4, 1 To 2) As String
Dim titles As Integer
Dim firstNames As Integer
Dim initials As Integer
firstRow = 1 'first row of data to look at
lastRow = Range("A65536").End(xlUp).Row 'find last row of data
targetRowCounter = 1 'how many rows to skip when writing out results
For i = firstRow To lastRow 'loop thru the data
titles = 0 'zero the counters
firstNames = 0
initials = 0
twoNames = False
myText = Split(Cells(i, 1).Text, " ") 'split up text based on where the " " characters are
myData(4, 1) = myText(UBound(myText)) 'assume last bit of text on the line is the last name
myText(UBound(myText)) = "" 'delete it after copying to myData array
For j = 0 To UBound(myText) 'lets see what we have left from that line of text
Select Case Right(myText(j), 1) 'strip out any full stops
Case "."
myText(j) = Left(myText(j), Len(myText(j)) - 1)
End Select
Select Case myText(j) 'look for any "and" or "&"
Case "and", "&"
twoNames = True
myText(j) = "" 'delete them once found
Case "Mr", "Mrs", "Dr", "Miss", "Ms", "Fr" 'look for any titles
titles = titles + 1
myData(1, titles) = "" 'zero the array first in case anything is left behind
myData(1, titles) = myText(j) 'copy title to myData array
myText(j) = "" 'delete it after copying to myData array
If titles > 1 Then twoNames = True
Case Else 'if not a full stop or title
If Len(myText(j)) > 1 Then 'if length is greater than 1 assume its a name
firstNames = firstNames + 1
myData(2, firstNames) = ""
myData(2, firstNames) = myText(j)
myText(j) = ""
Else 'if the length is only 1, assume its an initial
If myText(j) <> " " And initials < 2 Then
initials = initials + 1
myData(3, initials) = ""
myData(3, initials) = myText(j)
myText(j) = ""
Else
myText(j) = "" 'we don't want more than 2 initials so delete the rest
End If
End If
End Select
Next j
If twoNames = True And firstNames = 1 Then 'if we have 2 people, but only 1 first name, use the first one for both
firstNames = 2
myData(2, 2) = myData(2, 1)
End If
'start writing the results out to a second worksheet
Select Case titles
Case 0
Case 1
Sheets("Sheet2").Cells(i + targetRowCounter, 1) = myData(1, 1)
Sheets("Sheet2").Cells(i + targetRowCounter, 4) = myData(4, 1)
Case Else
Sheets("Sheet2").Cells(i + targetRowCounter, 1) = myData(1, 1)
Sheets("Sheet2").Cells(i + targetRowCounter + 1, 1) = myData(1, 2)
Sheets("Sheet2").Cells(i + targetRowCounter, 4) = myData(4, 1)
Sheets("Sheet2").Cells(i + targetRowCounter + 1, 4) = myData(4, 1)
End Select
Select Case firstNames
Case 0
Case 1
Sheets("Sheet2").Cells(i + targetRowCounter, 2) = myData(2, 1)
Sheets("Sheet2").Cells(i + targetRowCounter, 4) = myData(4, 1)
Case Else
Sheets("Sheet2").Cells(i + targetRowCounter, 2) = myData(2, 1)
Sheets("Sheet2").Cells(i + targetRowCounter + 1, 2) = myData(2, 2)
Sheets("Sheet2").Cells(i + targetRowCounter, 4) = myData(4, 1)
Sheets("Sheet2").Cells(i + targetRowCounter + 1, 4) = myData(4, 1)
End Select
Select Case initials
Case 0
Case 1
Sheets("Sheet2").Cells(i + targetRowCounter, 3) = myData(3, 1)
Case 2
Sheets("Sheet2").Cells(i + targetRowCounter, 3) = myData(3, 1)
Sheets("Sheet2").Cells(i + targetRowCounter + 1, 3) = myData(3, 2)
End Select
If titles > 1 Or firstNames > 1 Then
targetRowCounter = targetRowCounter + 1 'need to add an extra line when 2 names are found in the one line of text
End If
Next i