I’m trying to create a VBA code that will extract specific information from a text string within an Excel column. I need to keep the first four words of each cell, followed by the last name and first name. For example, if a cell contains “Dr. John Doe Smith, MD,” I want the output to be “Dr John Doe Smith Doe”. I’m struggling with manipulating the text string to achieve this desired format. Could someone please assist me in writing the VBA code to accomplish this task. I have created a code that removes all the infomrastion excet the first four words that works fine but really stuggling with the First and Last name.

Sub RemoveWordsAfterFour()

  Dim lastRow As Long
  Dim cell As Range

  ' Find the last row with data in column A
  lastRow = Cells(Rows.Count, 1).End(xlUp).Row

  ' Loop through each cell in column A
  For Each cell In Range("A1:A" & lastRow)
    ' Split the cell value into words
    Dim words As Variant
    words = Split(cell.Value)

    ' Check if there are more than four words
    If UBound(words) >= 4 Then
      ' Retain only the first four words
      ReDim Preserve words(1 To 4)

      ' Join the remaining words back into a string
      cell.Value = Join(words, " ")
    End If
  Next cell
End Sub

I tried this but did not work for me.

Sub ExtractFirstFourAndLastTwo()
    Dim originalString As String
    Dim wordArray() As String
    Dim newString As String

    ' Replace "YourTextHere" with the actual cell reference or string
    originalString = Range("A1").Value  ' Adjust cell reference as needed

    ' Split the string into an array of words
    wordArray = Split(originalString, " ")

    ' Build the new string with the first four and last two words
    newString = Join(Array(wordArray(0), wordArray(1), wordArray(2), wordArray(3), wordArray(UBound(wordArray) - 1), wordArray(UBound(wordArray))), " ")

    ' Output the result
    Range("B1").Value = newString  ' Adjust cell reference as needed
End Sub