2

I have a spreadsheet where column A is a list of names. Some of these names have titles (e.g., Mr John Doe, Miss Jane Doe, Mrs Jane Bloggs, Cllr Joe Bloggs etc) some of the names do not (just Joe Doe, John Bloggs, Jane Doe etc). I've been asked to split the names into three columns - Title, First Name, Last Name.

When I try the simple "text to columns", it's fine where there is a title, but where there isn't one, the first name defaults to the title column.

Is there a way to have the data split into the correct cells, or is it going to be a lot of manual work for someone?

4

2 回答 2

1

您可以使用 VBA 来完成此操作。

您将创建两个不同的数组。第一个是您的原始数据（您的单列）preArr()，以及您的新数组，该数组将被写回到postArr()已为三列标注尺寸的工作表中ReDim postArr(..., 1 To 3)。

首先，测试来自的字符串是否preArr(i, 1)包含已知的称呼。如果是这样，那么您将第一个拆分字符串添加到postArr(, 1)- 否则您不会在此列中添加任何内容。

旁注：您可以在此行添加额外的称呼：

.Pattern = "^(?:MRS?|MS|MIS+|CLLR|DR)\.?\s"

这是一个正则表达式，但只需添加另一个|分隔符以进行额外检查。我将 MR 和 MRS 合并为一组，如果您想知道的话，?它是S可选的。

这是完整的程序：

Option Explicit

Sub splitOnNames()

    Dim preArr(), postArr(), ws As Worksheet, preRng As Range
    Set ws = Selection.Parent
    Set preRng = Selection
    
    preArr = preRng.Value
    If UBound(preArr, 2) > 1 Then
        MsgBox "This can only be done on a single column!", vbCritical
        Exit Sub
    End If
    ReDim postArr(LBound(preArr) To UBound(preArr), 1 To 3)
    
    Dim i As Long, x As Long, tmpArr
    For i = LBound(preArr) To UBound(preArr)
        If preArr(i, 1) <> "" Then
            tmpArr = Split(preArr(i, 1))
            If testSalutation(preArr(i, 1)) Then
                postArr(i, 1) = tmpArr(0)
                postArr(i, 2) = tmpArr(1)
                For x = 2 To UBound(tmpArr) 'Some last names have two names
                    postArr(i, 3) = Trim(postArr(i, 3) & " " & tmpArr(x))
                Next x
            Else
                postArr(i, 2) = tmpArr(0)
                For x = 1 To UBound(tmpArr) 'Some last names have two names
                    postArr(i, 3) = Trim(postArr(i, 3) & " " & tmpArr(x))
                Next x
            End If
            Erase tmpArr
        End If
    Next i
    
    With preRng
        Dim postRng As Range
        Set postRng = ws.Range(ws.Cells(.Row, .Column), _
                ws.Cells(.Rows.Count + .Row - 1, .Column + 2))
        postRng.Value = postArr
    End With

End Sub

Private Function testSalutation(ByVal testStr As String) As Boolean

    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Pattern = "^(?:MRS?|MS|MIS+|CLLR|DR)\.?\s"
        testSalutation = .Test(testStr)
    End With
    
End Function

现场观看：

在此处输入图像描述

于 2018-11-29T01:47:59.873 回答
0

如果我必须这样做，那么我使用“文本到列”。之后，我按第三列排序。现在所有只有 2 个值的行一个接一个地列出。我为所有这些行标记第一列，按“Ctrl + 或”或单击鼠标右键并选择“插入单元格”。然后你会被问到你喜欢向下还是向右移动。选择右移，一个单元格将按照您喜欢的方式排列。

于 2018-11-28T17:03:12.053 回答