I don't know if it is my cognitive process or your explanations, but the more you explain the more confusing your requirement becomes.
I don't know if you want the project name that contains the five digit code e.g. 'P1234' or whether you want the full path. The following will provide both.
strPath is the path to the customer - "\\NEWBENSON\Projects\drawings\Customer" - No end slash
fPath1 is the path of the project - "\\NEWBENSON\Projects\drawings\Customer\P1234 Liverpool Street Station\"
strProject is the project - "P1234 Liverpool Street Station"
I still don't know where you want the Correspondence folders - in the customer folder or the project folder - and I don't know what you want for the Excel part you highlighted, but all the options you have raised are available by using the appropriate variables.

Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Private Function GetPath(strRootPath As String) As String
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRootPath)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder) & Chr(92)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Dim vProject As Variant
Dim strProject As String

    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
                      "The path will be created if it doesn't exist.", _
                      "Save Message")
    If fPath1 = "" Then
        MsgBox "User cancelled"
        GoTo lbl_Exit
    End If    
strPath = strRoot & fPath1
Debug.Print strPath
    CreateFolders strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"

    fPath2 = GetPath(strRoot & fPath1)
    If fPath2 = "" Then
        MsgBox "The ID entered does not exist"
        GoTo lbl_Exit
    End If
Debug.Print fPath2
    vProject = Split(fPath2, Chr(92))
    strProject = vProject(UBound(vProject) - 1)
Debug.Print strProject

'End 'Remove this line after testing the paths

    If olItem.sender Like "*@dbensoncontrols.co.uk" Then    'Looks for messages from you
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
    'CopyToExcel olItem, strPath    'The line goes here
lbl_Exit:
    Exit Sub
End Sub