excel公式有助于拆分复杂名称

Question

I have been tasked with some string manipulation and today must be my bad head day as it is proving more difficult than I expected.

I have to take the initials of the first and second and third name from the first and second and third columns along with any surnames

Plus we need to keep the title.

Here is an example of the long name as it stands now:

Mr C Chrysostomou & Mr N Chrysostomou & Mrs A Chrysostomou

Mrs M Karseras & Ms P Hadjisoteriou & Mrs E Athanasiou

Mrs A Theodorou & Mr A Aristotelou & Mrs G Naziri & M Karmiou Mrs L Vazanias & Mrs G

Braithwaite & Mrs Helen West Mrs L Vazanias & Mrs G Braithwaite & Mrs

Helen West Mrs Olympia Pieridou & Mrs T&mr M & Mr C & Mrs K

Michaelides Miss JA Santamas& Mrs MT Santama- Solomonides& Mrs Lida

Santama Miss JA Santamas& Mrs MT Santama- Solomonides& Mrs Lida

Santama Mr Polydoros Polydorou & Mrs Maro Themistocleous & Mrs Sylvia

Polydorou Mr Themis & Mrs Androulla & Mr Nicholas & Mrs Vasso Gina

Demetriou Mrs SK Makkofaides & Mr Z Koullas & Mrs Y Koullas & Mrs R

Kleopa Mr G Zorzy & Mrs H Louca Zorzy & Mr S Stavropoulos & Mrs Y

Stavropoulos Mrs M Franceschina & Ms C Eugeniou & Ms OL Toumazides

T/a The Three Cupcakes Mr David & Mrs Eileen Nixon Dhnixon & Co. - Office Account

as you can see, these could be considered to be joint bank accounts between 2 or even 3 persons. we will have to keep the tite, which could be Mr, Miss, Ms, Dr, Doctor , or Messrs along with the initials of the first and second names and the full surname, and the total should be less than 35 characters !

so, here is what I have been trying after some searching on the web:

=IF(LEN(TRIM(E:E))-LEN(SUBSTITUTE(TRIM(E:E)," ",""))>=1,MID(TRIM(E:E),FIND(" ",TRIM(E:E))+1,1),"")& " " &IF(LEN(TRIM(E:E))-LEN(SUBSTITUTE(TRIM(E:E)," ",""))>=2,MID(SUBSTITUTE(TRIM(E:E)," ","",1),FIND(" ",SUBSTITUTE(TRIM(E:E)," ","",1))+1,1),"")

that gets the initials, but only the first 2

=RIGHT(J:J,LEN(J:J)-FIND(" ",J:J)+1)

gets the surname but isn't working correctly.

am I over thinking this, or under thinking it?

What is my best approach to the data?

thanks Philip

Answer 1

This should get you started.

Lets say your data looks like this

Paste this code in a module. (Note: This code is not extensively tested but conveys the message)

Option Explicit

Sub Sample()
    Dim MyAr As Variant
    Dim FinalAr() As String, TmpAr() As String
    Dim ws As Worksheet
    Dim lrow As Long, i As Long, n As Long, j As Long

    '~~> Set this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> get last row of col A
        lrow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Store the values in an array
        MyAr = .Range("A1:A" & lrow)

        '~~> Loop through the array and split it on "&" and store it in another array
        For i = LBound(MyAr) To UBound(MyAr)
            If InStr(1, MyAr(i, 1), "&") Then
                TmpAr = Split(MyAr(i, 1), "&")

                For j = LBound(TmpAr) To UBound(TmpAr)
                    n = n + 1
                    ReDim Preserve FinalAr(n)
                    FinalAr(n) = Trim(TmpAr(j))
                Next j
            Else
                n = n + 1
                ReDim Preserve FinalAr(n)
                FinalAr(n) = Trim(MyAr(i, 1))
            End If
        Next i

        '~~> Past the outcome in Col B
        .Range("B1").Resize(UBound(FinalAr) + 1, 1).Value = Application.Transpose(FinalAr)

        '~~> Replace all mrs/mr etc
        .Columns(2).Replace What:="MRS", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

        .Columns(2).Replace What:="MR", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

        .Columns(2).Replace What:="MISS", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

        '~~> Find Last Row of Col B
        lrow = .Range("B" & .Rows.Count).End(xlUp).Row

        '~~> Loop through col B and split the names
        For i = 2 To lrow
            If InStr(1, .Range("B" & i), " ") Then
                TmpAr = Split(Trim(.Range("B" & i)), " ")

                n = 1

                For j = LBound(TmpAr) To UBound(TmpAr)
                    .Range("B" & i).Offset(, n).Value = TmpAr(j)
                    n = n + 1
                Next
            Else
                .Range("C" & i).Value = .Range("B" & i).Value
            End If
        Next i
    End With
End Sub

OutCome (Screenshot)