[已解决]如何提取相同数值?

zhouxingyu

哪位老师帮忙看看:
如何用用代码提取相同数值,(如果方便的话也提取不同数值)
用公式似乎无法解决,不知用vba可否?详见附件.十分感谢!
提取相同数值.zip (8.26 KB, 下载次数: 26)

2016-4-20 12:14 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-20 14:15

看懂了，感觉比较难。凑了一个，结果和模拟结果略有不同。

1. Dim xs
   
2. Sub tq()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("h1:k" & [h65536].End(3).Row)
   
5.     For i = 2 To UBound(arr) - 1
   
6.         x = arr(i, 1)
   
7.         For j = i + 1 To UBound(arr)
   
8.             y = arr(j, 1)
   
9.             If ISOK(x, y) Then
   
10.                 xrr = Split(xs, ",")
    
11.                 If arr(i, 2) = "" Then arr(i, 2) = xrr(0): arr(i, 3) = xrr(1): arr(i, 4) = y
    
12.                 If arr(j, 2) = "" Then arr(j, 2) = xrr(0): arr(j, 3) = xrr(2): arr(j, 4) = x
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     [L1].Resize(UBound(arr), 4) = arr
    
17. End Sub
    
18. 
    
19. Function ISOK(a, b) As Boolean      '是否相似，并返回x,y的相似数xs
    
20.     xs = ""
    
21.     x = a: y = b
    
22.     For i = 1 To Len(x)
    
23.         p = Mid(x, i, 1)
    
24.         For j = 1 To Len(y)
    
25.             If Mid(y, j, 1) = p Then
    
26.                 xs = xs & p
    
27.                 Mid(y, j, 1) = "A"
    
28.                 Mid(x, i, 1) = "A"
    
29.                 Exit For
    
30.             End If
    
31.         Next
    
32.     Next
    
33.     If Len(xs) = 5 Then
    
34.         ISOK = True
    
35.         xs = Replace(xs & "," & x & "," & y, "A", "")     'Like  "T5689,3,7"，第一位为相似数，第二位为第一个不同数，第三位为第二个不同数
    
36.     End If
    
37. End Function
    

复制代码

跳转到最佳答案楼层

爱疯

看不懂题意

zhouxingyu

爱疯 发表于 2016-4-20 11:27
看不懂题意

完了,爱版看不懂.

爱疯

zhouxingyu 发表于 2016-4-20 11:32
完了,爱版看不懂.

我看不看的懂，一点儿也不重要。
重要的是，大家能否看懂。


建议：比如可用文件简单说明一下，
结果1是如何如何得到的。
结果2是如何如何得到的。

zhouxingyu

爱疯 发表于 2016-4-20 11:39
我看不看的懂，一点儿也不重要。
重要的是，大家能否看懂。

说的是,我再完善一下.

zhouxingyu

已重新编辑,不知表述明白了没有.

grf1973

看懂了，感觉比较难。凑了一个，结果和模拟结果略有不同。

1. Dim xs
   
2. Sub tq()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("h1:k" & [h65536].End(3).Row)
   
5.     For i = 2 To UBound(arr) - 1
   
6.         x = arr(i, 1)
   
7.         For j = i + 1 To UBound(arr)
   
8.             y = arr(j, 1)
   
9.             If ISOK(x, y) Then
   
10.                 xrr = Split(xs, ",")
    
11.                 If arr(i, 2) = "" Then arr(i, 2) = xrr(0): arr(i, 3) = xrr(1): arr(i, 4) = y
    
12.                 If arr(j, 2) = "" Then arr(j, 2) = xrr(0): arr(j, 3) = xrr(2): arr(j, 4) = x
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     [L1].Resize(UBound(arr), 4) = arr
    
17. End Sub
    
18. 
    
19. Function ISOK(a, b) As Boolean      '是否相似，并返回x,y的相似数xs
    
20.     xs = ""
    
21.     x = a: y = b
    
22.     For i = 1 To Len(x)
    
23.         p = Mid(x, i, 1)
    
24.         For j = 1 To Len(y)
    
25.             If Mid(y, j, 1) = p Then
    
26.                 xs = xs & p
    
27.                 Mid(y, j, 1) = "A"
    
28.                 Mid(x, i, 1) = "A"
    
29.                 Exit For
    
30.             End If
    
31.         Next
    
32.     Next
    
33.     If Len(xs) = 5 Then
    
34.         ISOK = True
    
35.         xs = Replace(xs & "," & x & "," & y, "A", "")     'Like  "T5689,3,7"，第一位为相似数，第二位为第一个不同数，第三位为第二个不同数
    
36.     End If
    
37. End Function
    

复制代码

zhouxingyu

grf1973 发表于 2016-4-20 14:15
看懂了，感觉比较难。凑了一个，结果和模拟结果略有不同。

非常不错了.这题是相当的难,已经明确用公式是无法解决的.
没想到让你这位大神给搞定了,十万分的佩服,十二万分的感谢!

zhouxingyu

看下载量不少.这道难题如还有其它解决方法,老师们不妨拿出来分享,我可以再开新贴给最佳.