根据分值段将两列姓名重排

GUQLM

请教各位老师:我需要根据相似度值的区段，调整姓名的排列。检索过已经有的方案，但是需要调整，所以冒昧来请老师们帮助。
感谢各位老师关注和帮助。

模拟数据有误，需要保持小数点2位数，否则结果就不同。临界值不进位。现再次重新发布，麻烦老师们，也麻烦审核的老师了。


根据分数段重排3.rar (26.92 KB, 下载次数: 3)

2024-3-11 11:59 上传

点击文件名下载附件

limonet

关键字：partition+array

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Rst As Object, i%, Arr As Variant, Brr As Variant
    Arr = Array(100, 99, 89, 79, 69, 59)
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select 姓名,partition(int(相似度*100),50,100,10) as Part From [Sheet1$A:C] Union all " _
               & "Select 姓名2,partition(int(相似度*100),50,100,10) as Part From [Sheet1$A:C]"
    StrSQL = "Select 姓名,mid(part,instr(part,':')+1)*1 as Part From (" & StrSQL & ")"
    Set Rst = Cn.Execute(StrSQL)
    For i = 0 To UBound(Arr)
        Rst.Filter = "Part=" & Arr(i): Brr = Rst.getrows(-1, 0, "姓名")
        Range("A2").Offset(, i).Resize(UBound(Brr, 2) + 1, 1) = Application.Transpose(Brr)
    Next i
End Sub

GUQLM

limonet 发表于 2024-3-11 11:06
Sub limonet()
    Dim Cn As Object, StrSQL$, Rst As Object, i%, Arr As Variant, Brr As Variant
    ...

感谢limonet老师出手相助。
我手工核对了100%相似度的结果，发现姓名151 和2151放到[90-100）%分值段了。其他分值段还没核对。可以麻烦您看看吗？

GUQLM

limonet 发表于 2024-3-11 11:06
Sub limonet()
    Dim Cn As Object, StrSQL$, Rst As Object, i%, Arr As Variant, Brr As Variant
    ...

limonet老师i您好，感谢您的回复。我查了100%值段的结果，发现我的模拟文件错了，把姓名151 姓名2151放到[90-100)%值段了，非常抱歉。能帮我修改下程序吗?

limonet

说好的：各分数段小数不进位

GUQLM

limonet 发表于 2024-3-11 11:37
说好的：各分数段小数不进位

真抱歉，我用您发布的文件核对，原来数据是小数点2位数，但是我收到的程序变为无小数点了，所以进位了。是我粗心，我重新检查。

再报告老师：我恢复了数据的小数点2位，程序运行结果准确了。再次感谢您老师。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。

1. Sub ykcbf()   '//2024.3.11
   
2.     r = Cells(Rows.Count, 1).End(3).Row
   
3.     arr = Range("a1").Resize(r, 3)
   
4.     b = [{1,0.9,0.8,0.7,0.6,0.5}]
   
5.     u = UBound(b)
   
6.     ReDim brr(1 To UBound(arr) * 2, 1 To u)
   
7.     For x = 1 To u
   
8.         m = 0
   
9.         c = c + 1
   
10.         For j = 1 To 2
    
11.             For i = 2 To UBound(arr)
    
12.                 If c = 1 Then
    
13.                     If arr(i, 3) = b(x) Then
    
14.                         m = m + 1
    
15.                         brr(m, c) = arr(i, j)
    
16.                     End If
    
17.                 Else
    
18.                     If arr(i, 3) >= b(x) And arr(i, 3) < b(x - 1) Then
    
19.                         m = m + 1
    
20.                         brr(m, c) = arr(i, j)
    
21.                     End If
    
22.                     
    
23.                 End If
    
24.             Next
    
25.             m = m + 1
    
26.             brr(m, c) = "....."
    
27.         Next
    
28.         Max = IIf(Max < m, m, Max)
    
29.     Next
    
30.     [e2:j10000] = ""
    
31.     [e2].Resize(Max, 6) = brr
    
32.     MsgBox "OK！"
    
33. End Sub
    
34. 
    

复制代码

GUQLM

ykcbf1100 发表于 2024-3-11 14:23
参与一下。。

感谢ykcbf1100老师的帮助，程序很快，很准确。