相似匹配查找和完全匹配找查的问题

zhxj1983 · 发表于 2017-6-21 14:48

本帖最后由 zhxj1983 于 2017-8-19 09:59 编辑

目前厂生产的产品，有些是特殊订制的，一般特殊定制的我们会用原有相似的材料来进行加工使用，规格这里，我们都是以150*190 120*190这样来体现的，现在要麻烦老师帮忙处理的就是这种特殊的怎么在常规里面找出相近的规格来进行加工，而不用自己一个一个去看，具体看下附件

zhxj1983 · 发表于 2017-6-21 15:21

有没有老师知道的，帮忙看一下怎么设置

grf1973 · 发表于 2017-6-21 16:31

Sub grf()
Set dmn = CreateObject("scripting.dictionary")
Set dmx = CreateObject("scripting.dictionary")
brr = Range("q2:q" & [q65536].End(3).Row) '标准
For i = 1 To UBound(brr)
x = brr(i, 1)
dmn(x) = Val(x)
dmx(x) = Val(Split(x, "*")(1))
Next
arr = Range("a2:a" & [a65536].End(3).Row)
For i = 1 To UBound(arr)
y = arr(i, 1)
If Not dmn.exists(y) Then
ymn = Val(y)
ymx = Val(Split(y, "*")(1))
Delta = ymx
For Each x In dmn.keys
s = Abs(ymn - dmn(x)) + Abs(ymx - dmx(x))
If s < Delta Then Delta = s: arr(i, 1) = x
Next
End If
Next
[b2].Resize(UBound(arr)) = arr
End Sub

复制代码

zhxj1983 · 发表于 2017-6-21 19:20

grf1973 发表于 2017-6-21 16:31

用宏做可以哦，老师，如果是像这种150*（95+95）规格的也能找出来吗？比如我标准规格有150*（95+95）的，然后我定制的有147*（93+93）这样的，能自动找出找相近这个150*（95+95）的吗？

grf1973 · 发表于 2017-6-21 21:36

可以用正则找出每行的所有数字，然后比较，找出最小差异者。

zhxj1983 · 发表于 2017-6-21 23:22

grf1973 发表于 2017-6-21 21:36
可以用正则找出每行的所有数字，然后比较，找出最小差异者。

老师你能不能在刚才的那个附件中修改一下，重新再传附件给我，先谢谢了，我对宏不太懂，不知道怎么改

grf1973 · 发表于 2017-6-22 10:05

Sub grf()
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
brr = Range("q2:q" & [q65536].End(3).Row) '标准
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\d+"
For i = 1 To UBound(brr) '把标准里的所有数字提取出来，组成",500,95,95"类型的字符串，以便比较
x = brr(i, 1)
Set ma = .Execute(x)
For Each m In ma
d(x) = d(x) & "," & m '数字连成字符串
d1(x) = d1(x) + 1 '由几个数值组成
Next
Next
arr = Range("a2:a" & [a65536].End(3).Row)
For i = 1 To UBound(arr)
y = arr(i, 1)
If Not d.exists(y) Then
xstr = ""
Set ma = .Execute(y)
For Each m In ma
xstr = xstr & "," & m '数字连成字符串
Next
yrr = Split(xstr, ",") '待比较的数
n = UBound(yrr)
Delta = 1000
For Each x In d.keys
If n = d1(x) Then '有相同个数值的作比较
xrr = Split(d(x), ",") '标准
s = 0
For k = 1 To n
s = s + Abs(Val(xrr(k)) - Val(yrr(k))) '比较核心：标准各数和待比较数对应位置相减的绝对值相加最小
If s < Delta Then Delta = s: arr(i, 1) = x
Next
End If
Next
End If
Next
End With
[b2].Resize(UBound(arr)) = arr
End Sub

复制代码

zhxj1983 · 发表于 2017-6-23 16:45

grf1973 发表于 2017-6-22 10:05

老师，是不是代码有错了，我发现两个错误的地方，第一个是120*198，为什么选择的是120*190，而不是选择120*200？？正常应该是要选120*200的，只有大的规格才能切成小的规格。还有这个150*（92+92），为什么它选的不是150*（95+93）这个比较接近的规格呢？？

zhxj1983 · 发表于 2017-6-24 19:11

grf1973 发表于 2017-6-22 10:05

老师，我说的问题麻烦您看一下

grf1973 · 发表于 2017-6-26 09:30

按新要求小改了一下，应该没问题了。

Sub grf()
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
brr = Range("q2:q" & [q65536].End(3).Row) '标准
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\d+"
For i = 1 To UBound(brr) '把标准里的所有数字提取出来，组成",500,95,95"类型的字符串，以便比较
x = brr(i, 1)
Set ma = .Execute(x)
For Each m In ma
d(x) = d(x) & "," & m '数字连成字符串
d1(x) = d1(x) + 1 '由几个数值组成
Next
Next
arr = Range("a2:a" & [a65536].End(3).Row)
For i = 1 To UBound(arr)
y = arr(i, 1)
If Not d.exists(y) Then
xstr = ""
Set ma = .Execute(y)
For Each m In ma
xstr = xstr & "," & m '数字连成字符串
Next
yrr = Split(xstr, ",") '待比较的数
n = UBound(yrr)
Delta = 1000
For Each x In d.keys
If n = d1(x) Then '有相同个数值的作比较
xrr = Split(d(x), ",") '标准
s = 0
For k = 1 To n
If Val(xrr(k)) - Val(yrr(k)) < 0 Then Exit For '标准规格各项必须大于待比较的产品规格
s = s + Abs(Val(xrr(k)) - Val(yrr(k))) '比较核心：标准各数和待比较数对应位置相减的绝对值相加最小
Next
If s < Delta And k = n + 1 Then Delta = s: arr(i, 1) = x
End If
Next
End If
Next
End With
[b2].Resize(UBound(arr)) = arr
End Sub

复制代码

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