如何从名称列中的每个单元格中提取姓氏并将其分配给名称数组？

Question

我认为我有一个好的开始，但我很难将它带到终点线。有人可以帮帮我吗？

我的电子表格中有一个名称列 (G)。我想从每个单元格中提取唯一的姓氏并将其分配给一个名为 name_array 的数组。

我知道我的 If 函数正在工作，因为如果我将每个 name_cell 设置为 LastName 变量，它只会替换列的每个单元格中的姓氏，但我不知道如何将其分配给数组。

到目前为止，这是我的代码。有人可以帮我指出我所缺少的吗？

Sub create_namear()

Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(name_range.Cells.Count)

For Each name_cell In name_range.Cells
    Dim Lastname As String
            If InStr(name_cell, " ") > 0 Then
            Lastname = Split(name_cell, " ")(1)
            End If
    name_array(n) = lastname.value
    n = n + 1
Next name_cell

Debug.Print name_array(1)

End Sub

Name Column

Answer 1

这是另一种实现您想要的不循环的方法。我已经对代码进行了注释，因此您理解它应该没有问题。

基本逻辑

要获取SPACE之后的部分，可以使用公式=IFERROR(MID(G2,SEARCH(" ",G2,1),LEN(G2)-SEARCH(" ",G2,1)+1),"")

现在在整个范围内应用公式并使用INDEX(FORMULA) 获取值。这个方法的解释可以在Convert an entire range to uppercase without looping through all the cells

代码

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lRow As Long, i As Long
    Dim FinalAr As Variant
    
    '~~> Set this to the relevant sheet
    Set ws = Sheet1
    
    With ws
        '~~> Find last row in col G
        lRow = .Range("G" & .Rows.Count).End(xlUp).Row
        
        '~~> Set your range
        Set rng = .Range("G2:G" & lRow)
        
        '~~> Get all the last names from the range and store them
        '~~> in an array in 1 go!
        FinalAr = Evaluate("index(IFERROR(MID(" & _
                           rng.Address & _
                           ",SEARCH("" ""," & _
                           rng.Address & _
                           ",1),LEN(" & _
                           rng.Address & _
                           ")-SEARCH("" ""," & _
                           rng.Address & _
                           ",1)+1),""""),)")
    End With
    
    '~~> Check the output
    For i = LBound(FinalAr) To UBound(FinalAr)
        Debug.Print ">"; FinalAr(i, 1)
    Next i
End Sub

在行动

替代方法

1. 使用文本到列，然后将输出存储在数组中
2. 使用 Flash Fill 获取姓氏，然后将输出存储在数组中。这种方法的一个缺点是没有姓氏的名字，它会显示名字而不是空白。

Answer 2

Sub create_namear()

Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long

Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(0 to name_range.Cells.Count-1) '### 0-based array... 

For Each name_cell In name_range.Cells
    If InStr(name_cell, " ") > 0 Then
        name_array(n) = Split(name_cell, " ")(1) 'simplify...
    End If
    n = n + 1
Next name_cell

Debug.Print name_array(1)

End Sub

Answer 3

使用Filter() 的解决方案（不包括缺少姓氏的值）：

Sub ExtractLastNames()
    Dim arr, name_array, i
    
    arr = WorksheetFunction.Transpose(Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)) 'first, get the horizontal one-dimentional array from cells
    name_array = Filter(arr, " ", True) 'second, filter out one-word and empty elements
    For i = LBound(name_array) To UBound(name_array)
        name_array(i) = Split(name_array(i))(1) 'third, replace name_array values with extracted lastnames
    Next
    Range("H2").Resize(UBound(name_array) + 1) = WorksheetFunction.Transpose(name_array) ' output
End Sub

Answer 4

姓氏到数组

• 以下将把最后出现的空格后面的子字符串视为姓氏。

Option Explicit

Sub create_namear()
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    Dim nRange As Range
    Set nRange = ws.Range("G2:G" & ws.Range("G" & ws.Rows.Count).End(xlUp).Row)
    Dim rCount As Long: rCount = nRange.Rows.Count
    Dim nArray() As String: ReDim nArray(0 To rCount - 1)
    
    Dim nCell As Range
    Dim n As Long
    Dim nmLen As Long
    Dim LastSpacePosition As Long
    Dim nmString As String
    Dim LastName As String
    
    For Each nCell In nRange.Cells
        nmString = CStr(nCell.Value)
        If InStr(1, nmString, " ") > 0 Then
            LastSpacePosition = InStrRev(nCell.Value, " ")
            nmLen = Len(nmString)
            If LastSpacePosition < nmLen Then
                LastName = Right(nmString, nmLen - LastSpacePosition)
                nArray(n) = LastName
                n = n + 1
            End If
        End If
    Next nCell
    
    If n = 0 Then Exit Sub
    If n < rCount Then
        ReDim Preserve nArray(0 To n - 1)
    End If
    
    Debug.Print "[" & LBound(nArray) & "," & UBound(nArray) & "]" _
        & vbLf & Join(nArray, vbLf)

End Sub

Answer 5

Siddharth公式求值的扩展

这些对 Siddharth 的有效代码的补充可能会有所帮助，如果有少于 2 个数据行以避免

• 标题行 1:1 的不需要的评估（如果没有数据，请参阅1.b 部分） - 这可以通过纠正结果行号lRow 仅1 到2 的实际数据行开始。
• 错误 9 下标超出范围（如果是单个元素；参见3.b 部分） - 请注意，这需要转换 1 - 通过尺寸足够大的tmp 数组将结果调整为 2 维结果数组。

此外，我简化了 公式构建 以避免重复 rng.Address 插入只是为了展示另一种方法（请参阅2. 部分） em>。

Sub GetLastName()
    '0. Set this to the relevant sheet
    Dim ws As Worksheet: Set ws = Sheet1
    With ws
    '1. Define data range
    '1. a) Find last row in col G
        Dim lRow As Long
        lRow = .Range("G" & .Rows.count).End(xlUp).Row
    '1. b) Provide for empty data set    ' << Added to avoid title row evaluation
        If lRow = 1 Then lRow = 2      
    '1. c) Set your range
        Dim rng As Range:  Set rng = .Range("G2:G" & lRow)
        
    '2. Define formula string parts      ' << Modified for better readibility       
    Dim FormulaParts()
        FormulaParts = Array("INDEX(IFERROR(MID(", _
                      ",SEARCH("" "",", _
                      ",1),LEN(", _
                      ")-SEARCH("" "",", _
                      ",1)+1),""""),)")
        '3. Assign last names to 2-dim array results
    '3. a) Get all the last names from the range and store them
        Dim results
        results = Evaluate(Join(FormulaParts, rng.Address))
    End With
    
    '3.b) Provide for single results   '<< Added to avoid Error 9 Subscript o/Rng 
    If UBound(results) = 1 Then        '<< Force single element into 2-dim array
        Dim tmp(1 To 1, 1 To 1)
        tmp(1, 1) = results(1)
        results = tmp
    End If

    'h) Display in VB Editor's immediate window
    Dim i As Long
    For i = LBound(results) To UBound(results)
        Debug.Print ">"; results(i, 1)
    Next i
    'i) Write last names to target  '<< Added to demonstrate writing back
    ws.Range("H2").Resize(UBound(results), 1) = results
End Sub