使用 VBA 脚本将全名解析为多个部分

Question

我为此寻找了一个完整的解决方案，但找不到一个可行的或我可以修改以工作的解决方案。我有一个全名列表，可能包括也可能不包括中间名、中间名首字母和后缀。使用 VBA 脚本，我需要将名称解析为适当的单独列，如下所示。（注意 - 后缀可以包括 Jr、Jr.、Sr、Sr.、II、III、IV 和 V...现在）

我最接近的是这段代码：（其中“emptyRow”已被确定为没有数据的第一个可用行）

 Dim MyText As String
 Dim i As Integer
 Dim MyResult() As String
 
 MyText = Range("A" & emptyRow).Value
 MyResult = Split(MyText)

 For i = 0 To UBound(MyResult)
     Cells(emptyRow, i).Value = MyResult(i)
 Next I

但是，它对缺失的项目没有任何作用，例如中间名或后缀。

关于如何让它发挥作用或不同的方法有什么想法吗？

(A1)Full Name	(B1)First Name	(C1)Middle Name	(D1)Last Name	(E1)Suffix
John Adam Doe Jr.	John	Adam	Doe	Jr.
John A Doe Jr	John	A	Doe	Jr
John Doe Jr	John		Doe	Jr
John Adam Doe	John	Adam	Doe
John A Doe	John	A	Doe
John Doe	John		Doe

更新：

所以，这就是我的想法。我确信它可以更漂亮，但我认为它有效。

    MyResult = Split(MyText)
    i = UBound(MyResult)
    Cells(emptyRow, 1).Value = MyResult(0)
    If MyResult(i) = "Jr." Or MyResult(i) = "Jr" Or MyResult(i) = "Sr." Or MyResult(i) = "Sr" Or MyResult(i) = "II" Or MyResult(i) = "ii" Or MyResult(i) = "III" Or MyResult(i) = "IIi" Or MyResult(i) = "Iii" Or MyResult(i) = "IiI" Or MyResult(i) = "iii" Or MyResult(i) = "iIi" Or MyResult(i) = "iiI" Or MyResult(i) = "iII" Or MyResult(i) = "iI" Or MyResult(i) = "Ii" Or MyResult(i) = "IV" Or MyResult(i) = "V" Or MyResult(i) = "iv" Or MyResult(i) = "v" Or MyResult(i) = "Iv" Or MyResult(i) = "iV" Then
        If i = 5 Then
            Cells(emptyRow, 4).Value = MyResult(i)
            Cells(emptyRow, 3).Value = MyResult(3) & " " & MyResult(4)
            Cells(emptyRow, 2).Value = MyResult(1) & " " & MyResult(2)
            ElseIf i = 4 Then
                Cells(emptyRow, 4).Value = MyResult(i)
                Cells(emptyRow, 3).Value = MyResult(2) & " " & MyResult(3)
                Cells(emptyRow, 2).Value = MyResult(1)
            ElseIf i = 3 Then
                Cells(emptyRow, 4).Value = MyResult(i)
                Cells(emptyRow, 3).Value = MyResult(2)
                Cells(emptyRow, 2).Value = MyResult(1)
            Else
                Cells(emptyRow, 4).Value = MyResult(i)
                Cells(emptyRow, 3).Value = MyResult(1)
        End If
        ElseIf i = 4 Then
            Cells(emptyRow, 3).Value = MyResult(3) & " " & MyResult(4)
            Cells(emptyRow, 2).Value = MyResult(1) & " " & MyResult(2)
            ElseIf i = 3 Then
                Cells(emptyRow, 3).Value = MyResult(2) & " " & MyResult(3)
                Cells(emptyRow, 2).Value = MyResult(1)
            ElseIf i = 2 Then
                Cells(emptyRow, 3).Value = MyResult(2)
                Cells(emptyRow, 2).Value = MyResult(1)
            Else
                Cells(emptyRow, 3).Value = MyResult(1)
    End If

想法??

Answer 1

这是我的看法。我在中间名或姓氏中加入了使用额外名字的选择。它是快速制作的，而且是相当基本的方法，我相信可以通过多种方式对其进行改进，但无论如何它都能很好地工作。

试试吧。只需设置和更改必要的部分。

Sub ExtractName()

Dim ws As Worksheet, lRow As Long, i As Long, SplitName, IsSuffix As Boolean
Dim LastNamePos As Integer, j As Integer, SplitLast As Integer, LastStart As Integer

Set ws = Sheets("Sheet1")
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row 'Change column as needed

With ws
    For i = 2 To lRow 'change starting row if needed
        SplitName = Split(.Range("A" & i), " ")
        SplitLast = UBound(SplitName)
        Select Case SplitName(SplitLast)
            Case "Jr", "Jr.", "Sr", "Sr.", "II", "III", "IV", "V"
                .Range("E" & i) = SplitName(SplitLast) 'Add Suffix to column
                IsSuffix = True
            Case Else
                IsSuffix = False
        End Select
        .Range("B" & i) = SplitName(0) 'Add first name to column

        If IsSuffix = True Then
            LastNamePos = 1
        Else
            LastNamePos = 0
        End If
        '---------------------- Extra names go to middle name
        .Range("D" & i) = SplitName(SplitLast - LastNamePos) 'Add last name to column
        For j = 1 To SplitLast - LastNamePos - 1 'Add middle names to column
            If .Range("C" & i) = "" Then
                .Range("C" & i) = SplitName(j)
            Else
                .Range("C" & i) = .Range("C" & i) & " " & SplitName(j)
            End If
        Next j
        '---------------------- Extra names go to last name
'        If IsSuffix = True And SplitLast >= 3 Then
'            .Range("C" & i) = SplitName(1)
'            LastStart = 2
'        ElseIf IsSuffix = False And SplitLast >= 2 Then
'            .Range("C" & i) = SplitName(1)
'            LastStart = 2
'        Else
'            LastStart = 1
'        End If
'        For j = LastStart To SplitLast - LastNamePos
'            If .Range("D" & i) = "" Then
'                .Range("D" & i) = SplitName(j)
'            Else
'                .Range("D" & i) = .Range("D" & i) & " " & SplitName(j)
'            End If
'        Next j
    Next i
End With

End Sub

使用 VBA 脚本将全名解析为多个部分

Use VBA Script To Parse Full Name Into Parts

excel

vba

parsing

office365