如何从名称列中的每个单元格中提取姓氏并将其分配给名称数组？
How do I extract the last name from each cell in a name column and assign it to name array?
我认为我有一个好的开始，但我很难把它带到终点线。有人可以帮我吗？
我的电子表格中有一个名称列 (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
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
这是实现您想要的效果的另一种方法无需循环。我已经对代码进行了注释，因此您理解它应该没有问题。
基本逻辑
要得到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
进行中
替代方法
- 使用 Text To 列，然后将输出存储在数组中
- 使用快速填充获取姓氏，然后将输出存储在数组中。这种方法的一个缺点是没有姓氏的名字，它会显示名字而不是空白。
使用 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
数组的姓氏
- 以下将把最后出现的space之后的子串视为姓
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
悉达多公式评估的扩展
这些对 Siddharth 的有效代码 的补充可能会有所帮助，如果少于 2 个数据行 以避免
- 标题行 1:1 的 不需要的评估（如果 根本没有数据 ，请参阅部分
1.b) - 这可以通过将仅 1 的结果行号 lRow 更正为 2. 的实际数据行开始来防止
- 错误 9 下标超出范围（在单个元素的情况下；参见
3.b) - 请注意，这需要通过足够尺寸的 tmp 数组将 1-dim 结果转换为 2-dim 结果数组。
此外，我简化了公式构建以避免重复 rng.Address插入只是为了展示另一种方法（参见 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
我认为我有一个好的开始，但我很难把它带到终点线。有人可以帮我吗？
我的电子表格中有一个名称列 (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
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
这是实现您想要的效果的另一种方法无需循环。我已经对代码进行了注释，因此您理解它应该没有问题。
基本逻辑
要得到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
进行中
替代方法
- 使用 Text To 列，然后将输出存储在数组中
- 使用快速填充获取姓氏，然后将输出存储在数组中。这种方法的一个缺点是没有姓氏的名字，它会显示名字而不是空白。
使用 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
数组的姓氏
- 以下将把最后出现的space之后的子串视为姓
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
悉达多公式评估的扩展
这些对 Siddharth 的有效代码 的补充可能会有所帮助，如果少于 2 个数据行 以避免
- 标题行 1:1 的 不需要的评估（如果 根本没有数据 ，请参阅部分
1.b) - 这可以通过将仅1的结果行号lRow更正为2. 的实际数据行开始来防止
- 错误 9 下标超出范围（在单个元素的情况下；参见
3.b) - 请注意，这需要通过足够尺寸的tmp数组将 1-dim 结果转换为 2-dim 结果数组。
此外，我简化了公式构建以避免重复 rng.Address插入只是为了展示另一种方法（参见 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