为了去避免近似同姓名（姓名最后两个字相同）分到同一班级，请大神帮忙用VBA提取这...

qqyyh

为了去避免近似同姓名（姓名最后两个字相同）分到同一班级，请大神帮忙用VBA提取这些近似同姓名信息以便查看。谢谢！！！ 为了去避免近似同姓名（姓名最后两个子相同）分到同一班级，请大神帮忙用VBA提取这些.zip (12.08 KB, 下载次数: 16)

2024-3-31 16:53 上传

点击文件名下载附件

ykcbf1100

是标色提示呢，还是直接提取这些名字？

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim ar, br, cr, vResult, i&, j&, k&, r&, dic As Object, vKey, t#
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    ar = Range("B1", Cells(Rows.Count, "P").End(xlUp)).Value
    br = Array(2, 1, 3, 13, 15)
   
    ReDim vResult(1 To UBound(ar), 1 To 5)
    For j = 0 To UBound(br)
        vResult(1, j + 1) = ar(1, br(j))
    Next j
    r = r + 1
   
    For i = 2 To UBound(ar)
        vKey = Right(ar(i, 2), 2)
        dic(vKey) = dic(vKey) & " " & i
    Next i
    For Each vKey In dic.keys
        cr = Split(dic(vKey))
        If UBound(cr) > 1 Then
            For j = 1 To UBound(cr)
                r = r + 1
                For k = 0 To UBound(br)
                    vResult(r, k + 1) = ar(cr(j), br(k))
                Next k
            Next j
        End If
    Next
    Range("Y9:AC" & Rows.Count).Clear
    [Y9].Resize(r, 5) = vResult
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

请参考附件。。。

清风竹-

请看附件。

swl4561255

参考代码：

1. Sub test()
   
2. ar = [B1].End(4).Row
   
3. Range("B1:P" & ar).Interior.ColorIndex = Null
   
4. MsgBox "已准备就绪，按确定键开始查找。"
   
5.   For i = 2 To ar
   
6.     If Application.CountIf(Range("C2:C" & ar), "*" & Right(Range("C" & i), 2)) > 1 Then
   
7.       Range(Cells(i, "B"), Cells(i, "P")).Interior.ColorIndex = 3
   
8.     End If
   
9.   Next
   
10. End Sub

复制代码

ykcbf1100

提取姓名，并且，相似名字已排序

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.31
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 3).End(3).Row
   
5.         arr = .[c1].Resize(r, 1)
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr), 1 To 2)
   
8.     For i = 2 To UBound(arr)
   
9.         s = Right(arr(i, 1), 2)
   
10.         d(s) = d(s) + 1
    
11.     Next
    
12.     For i = 2 To UBound(arr)
    
13.         s = Right(arr(i, 1), 2)
    
14.         If d(s) > 1 Then
    
15.             m = m + 1
    
16.             brr(m, 1) = arr(i, 1)
    
17.             brr(m, 2) = s
    
18.         End If
    
19.     Next
    
20.     With Sheets("Sheet2")
    
21.         .UsedRange.Offset(1).Clear
    
22.         .[a2].Resize(m, 2) = brr
    
23.         .[a2].Resize(m, 2).Sort .[b2], 1
    
24.         .[b2].Resize(m, 1) = ""
    
25.         .[a2].Resize(m, 1).Borders.LineStyle = 1
    
26.     End With
    
27.     Set d = Nothing
    
28.     MsgBox "OK！"
    
29. End Sub
    
30. 
    

复制代码

ykcbf1100

标色提示，已经写了，也上传一下吧，供参考。。。

ykcbf1100

仅供参考。。。

1. Sub ykcbf()  '//2024.3.31
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Me.Cells(Rows.Count, 2).End(3).Row
   
4.     arr = Me.[c1].Resize(r, 1)
   
5.     Me.Cells.Interior.ColorIndex = 0
   
6.     Me.Cells.Font.ColorIndex = 0
   
7.     For i = 2 To UBound(arr)
   
8.         s = Right(arr(i, 1), 2)
   
9.         d(s) = d(s) + 1
   
10.     Next
    
11.     For i = 2 To UBound(arr)
    
12.         Set Rng = Me.Cells(i, 3)
    
13.         s = Right(Rng.Value, 2)
    
14.         If d(s) > 1 Then
    
15.             Rng.Cells.Interior.ColorIndex = 8
    
16.         End If
    
17.     Next
    
18.     Set d = Nothing
    
19.     MsgBox "OK！"
    
20. End Sub
    

复制代码