多关键字找最佳匹配

aman1516 · 发表于 2015-4-25 21:06

还有这个：
字符串的相似度计算
http://club.excelhome.net/thread-901666-1-1.html

marchwen01 · 发表于 2015-4-25 22:23

总是不那么尽人意。

Sub Test()
Dim Reg As Object, arr, brr, i&, j&, Pat$, Pat2$, k%
Set Reg = CreateObject("VBScript.RegExp")
arr = Sheets("计划").[a4].CurrentRegion
brr = Sheets("物料").[a1].CurrentRegion
Reg.Global = True
With Sheets("结果")
For i = 2 To UBound(arr)
.Cells(i + k, 1) = i - 1
.Cells(i + k, 2) = Join(Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 7)), "/")
Pat = arr(i, 2) & "/" & Left(arr(i, 3), 1) & ".*/" & arr(i, 4) & ".*"
Pat2 = arr(i, 2) & arr(i, 1) & ".*?" & arr(i, 3) & "$"
Reg.Pattern = Pat & "|" & Pat2
For j = 2 To UBound(brr)
If Reg.Test(brr(j, 2)) Then
k = k + 1
.Cells(i + k, 2) = brr(j, 1)
.Cells(i + k, 3) = brr(j, 2)
.Cells(i + k, 4) = brr(j, 3)
End If
Next
Next
End With
End Sub

复制代码

hlly888 · 发表于 2015-4-25 22:58

aman1516 发表于 2015-4-25 20:35
谢谢，已通过筛选出部分数据，只是在“模糊”处理方面未能尽可能达到更精准的结果。
关键字是： brr( ...

测试后，请指出错误之处。

marchwen01 · 发表于 2015-4-25 22:59

Sub Test()
Dim Reg As Object, arr, brr, br$, i&, j&, Pat$, Pat2$, k%
Set Reg = CreateObject("VBScript.RegExp")
arr = Sheets("计划").[a4].CurrentRegion
brr = Sheets("物料").[a1].CurrentRegion
Reg.Global = True
With Sheets("结果")
For i = 2 To UBound(arr)
.Cells(i + k, 1) = i - 1
.Cells(i + k, 2) = Join(Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 7)), "/")
Pat = arr(i, 2) & "/" & Left(arr(i, 3), 1) & ".*/" & arr(i, 4) & ".*"
Pat2 = arr(i, 2) & arr(i, 1) & ".*?" & arr(i, 3) & "$"
Reg.Pattern = Pat & "|" & Pat2
For j = 2 To UBound(brr)
'下面两句修改过
br = Left(brr(j, 2), 1)
If Reg.Test(brr(j, 2)) Or Reg.Test(Replace(brr(j, 2), br, br & "/")) Then
k = k + 1
.Cells(i + k, 2) = brr(j, 1)
.Cells(i + k, 3) = brr(j, 2)
.Cells(i + k, 4) = brr(j, 3)
End If
Next
Next
End With
End Sub

复制代码

hlly888 · 发表于 2015-4-25 22:59

多关键字找最佳匹配2.zip (127.73 KB, 下载次数: 59)

aman1516 · 发表于 2015-4-26 00:06

marchwen01 发表于 2015-4-25 22:59

谢谢关注……全面测试一下

aman1516 · 发表于 2015-4-26 00:34

hlly888 发表于 2015-4-25 22:59

代码修改了吗：
Sub yy() 'hlly888
Range("a2:d65536").ClearContents
Application.ScreenUpdating = False
Range("a1:d65536").ClearFormats
Dim dc As Object, arr, brr(), i&, s&, j%, k%, n%
Set dc = CreateObject("scripting.dictionary")
x = Sheets("物料").Cells(Rows.Count, 1).End(xlUp).Row
arr = Sheets("物料").Range("a2:c" & x)
x2 = Sheets("计划").Cells(Rows.Count, 1).End(xlUp).Row
yrr = Sheets("计划").Range("a5:d" & x2)
ReDim brr(1 To UBound(arr), 1 To 4)

For j = 1 To UBound(yrr)
s = s + 1
brr(s, 1) = j
brr(s, 2) = yrr(j, 1) & "/" & yrr(j, 2) & "/" & yrr(j, 3) & "/" & yrr(j, 4)
Rows(s + 1).Font.Bold = True
'Rows(s + 1).Interior.ColorIndex = 19 ' 35
For i = 1 To UBound(arr)
      For k = 1 To 4
         If InStr(arr(i, 3), yrr(j, k)) > 0 Then
            n = n + 1
         End If
      Next
      If n = 4 Then
         s = s + 1
      brr(s, 2) = arr(i, 1)
      brr(s, 3) = arr(i, 2)
      brr(s, 4) = arr(i, 3)
      Rows(s + 1).Font.Size = 10
      End If
      n = 0
Next
Next

[a2].Resize(UBound(arr), 4) = brr
Application.ScreenUpdating = True
End Sub

还是都不尽人意

aman1516 · 发表于 2015-4-26 00:45

我觉得我在9楼的思路是对的，一步一步筛选，只是好像有点复杂。
“颜色”、“其它配置说明”项可以先整个关键词匹配，若无匹配时，再拆分单个字符匹配。
明天再好好想想.....

aman1516 · 发表于 2015-4-26 00:55

用 like 是否比 instr 更好些呢？

liu-aguang · 发表于 2015-4-26 11:24

必须明确以下几个问题,否则没有人能给出楼主希望的答案:
1.各项查找关键字,在实际原始数据中的变形情况. 楼主只给出了"型号"的各种变形;
2.各项关键字在原始数据中从左至右出现的总体顺序,是否都一样?
3.假如前四项都符合,不论"其它配置"有无都列出,还是只要该项存在,其它的就不再列出结果?
4.前四项同时出现是必须的吗?最佳匹配的具体含义是什么?

		自动登录	找回密码
密码			免费注册

[求助] 多关键字找最佳匹配