How do I extract the last name from each cell in a name column and assign it to name array?

Question

I think i've got a good start, but I'm having a tough time taking this to the finish line. Could someone help me out?

I have a name column(G) in my spreadsheet. I want to pull the only the last name out of each cell and assign it to an array called name_array.

I know that my If function is working because if I set each name_cell to the LastName variable it substitutes only the lastname in each cell of the column, but I cannot figure out how to assign that to the array.

Here is my code thus far. Can someone please help me out and point out what I'm missing?

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

Extension on Siddharth' s formula evaluation

These additions to Siddharth's valid code can be helpful, if there are less than 2 data rows in order to avoid

• an unwanted evaluation of the title row 1:1 (in case of no data at all, see section 1.b) - This can be prevented by correcting a resulting row number lRow of only 1 to the actual data row start of 2.
• Error 9 Subscript out of range (in case of a single element; see section 3.b) - Note that this requires to transform a 1-dim result to a 2-dim results array by means of a adequately dimensioned tmp array.

Furthermore I simplified the formula building to avoid repeated rng.Address insertions just to show another way of doing it (see section 2.).

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

Answer 2

Last Names to Array

• The following will consider the substring after the last occurring space as the last name.

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 3

Solution using Filter() (values with missing lastnames are excluded):

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

Here is another way to achieve what you want without looping. I have commented the code so you should not have a problem understanding it.

BASIC LOGIC

To get the part after SPACE, you can use the formula =IFERROR(MID(G2,SEARCH(" ",G2,1),LEN(G2)-SEARCH(" ",G2,1)+1),"")

Now applying the formula in the entire range and getting the value using INDEX(FORMULA). You can find the explanation of this method in Convert an entire range to uppercase without looping through all the cells

CODE

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

IN ACTION

ALTERNATIVE METHODS

1. Use Text To columns and then store the output in an array
2. Use Flash Fill to get the last names and then store the output in an array. One drawback of this method is that the names which do not have last name, it will show first name instead of a blank.

Answer 5

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