提取两个字符串中最大相同部分的字符串。

yjh_27

香川群子 发表于 2015-6-18 12:52
自定义函数 =f(s1,s2,[n],[k])
1.s1/s2为比较对象字符串、必须参数。
2.n为相同字符最低个数、可选参数。 ...

n=0  最好再设一个参数

香川群子

dyho2010 发表于 2015-6-18 20:35
谢谢，你的程序很棒，且注释得很仔细，我这种小白也可以看的懂，我以后可以通过更改参数实现其他我想要的 ...

自定义函数改进后，比较次数更为减少，速度效率更高！
在长字符串、大数据量时应该有好处。

1. Function f(s1$, s2$, Optional n& = 3, Optional k& = 1)
   
2.     If k = 1 Then s1 = LCase(s1): s2 = LCase(s2)
   
3.     If k = 2 Then s1 = UCase(s1): s2 = UCase(s2)
   
4.     If Len(s1) > Len(s2) Then s = s2: s2 = s1: s1 = s
   
5.     Do While i + r < Len(s1)
   
6.         i = i + 1: j = r
   
7.         Do While j < Len(s1)
   
8.             j = j + 1: s = Mid(s1, i, j): If InStr(s2, s) Then r = Len(s): f = s
   
9.         Loop
   
10.     Loop
    
11.     If n = 0 Then f = r Else If r < n Then f = ""
    
12. End Function

复制代码

参数设置没有变化。

但是请注意：如果含有相同长度的字符串有几组，则仅返回第一次出现的那一组。

香川群子

yjh_27 发表于 2015-6-18 20:44
n=0  最好再设一个参数

没问题。n=0是个不会冲突的冗余条件，可以这样设置。

我在楼下用Do循环方式重写了代码，效率更高！

Function f(s1$, s2$, Optional n& = 3, Optional k& = 1)
    If k = 1 Then s1 = LCase(s1): s2 = LCase(s2) 'k=1 时转为小写比较模式并输出
    If k = 2 Then s1 = UCase(s1): s2 = UCase(s2) 'k=2 时转为大写比较模式并输出
   'k=0时不做字符处理、因此是按通常原始状态即区分大小写的比较模式进行。

    If Len(s1) > Len(s2) Then s = s2: s2 = s1: s1 = s '设置长度小的字符串作为s1 提高效率

    Do While i + r < Len(s1) '仅比较至当前位置 i 的字符串长度不小于最大值 r 时
        i = i + 1: j = r            '每次按已知最大值r的长度作为比较长度 j 然后开始比较
        Do While j < Len(s1)  '当前位置的比较长度j不小于s1长度时继续比较
            j = j + 1: s = Mid(s1, i, j) '截取比较字符s、然后Instr检查s2中是否含有相同
            If InStr(s2, s) Then r = Len(s): f = s '如含有则更新最大长度时的s并记录r
        Loop
    Loop
    If n = 0 Then f = r Else If r < n Then f = "" '如参数设置n=0时返回个数r、如r不足n时则返回空白
End Function

如果含有相同长度的字符串有几组，则仅返回第一次出现的那一组。

xieyidh

都很好用,但是都在不同列的同一行上对比,我想需要的是在不同一行上对比,请高手们修改一下参数,以适应的范围更广.

小花鹿

写着玩玩：取最长相同部分
Sub test()
Dim ar, i&, j&, k&, s, s1, s2, s3, n&
ar = [a1].CurrentRegion
For i = 2 To UBound(ar)
    s = ""
    n = 0
    s1 = LCase(ar(i, 1))
    s2 = LCase(ar(i, 2))
    For j = 1 To Len(s1)
        For k = 1 To Len(s1) - j + 1
            s3 = Mid(s1, j, k)
            If InStr(s2, s3) > 0 And Len(s3) >= n Then
                s = s3
                n = Len(s3)
            End If
        Next k
    Next j
    ar(i, 1) = s
Next i
[g1].Resize(i - 1, 1) = ar
End Sub

香川群子

xieyidh 发表于 2015-6-19 09:55
都很好用,但是都在不同列的同一行上对比,我想需要的是在不同一行上对比,请高手们修改一下参数,以适应的范围 ...

用我的自定义函数。像工作表函数那样很方便地使用。任意位置都可以。

Zamyi

1. Function GetS$(s1$, s2$)
   
2. Dim s$
   
3. If Len(s1) > Len(s2) Then s = s2 Else s = s1: s1 = s2
   
4. n = Len(s)
   
5. For i = n To 1 Step -1
   
6.   For j = 1 To n - i + 1
   
7.     If InStr(s1, Mid(s, j, i)) Then GetS = Mid(s, j, i): Exit Function
   
8.   Next
   
9. Next
   
10. End Function

复制代码

zongyj

学习，思路很棒

Zamyi

如果要进行文本比较，Instr本身就可以，改为InStr(1,s1, Mid(s, j, i),1)。
22楼那样可谓笨到家。

yjh_27

香川群子 发表于 2015-6-19 09:13
没问题。n=0是个不会冲突的冗余条件，可以这样设置。

我在楼下用Do循环方式重写了代码，效率更高！
...

原代码n=0 时  输出 f=R有时会出错

1. Function f(s1$, s2$, Optional n& = 3, Optional k& = 1)
   
2.     If k = 1 Then s1 = LCase(s1): s2 = LCase(s2)
   
3.     If k = 2 Then s1 = UCase(s1): s2 = UCase(s2)
   
4.     If Len(s1) > Len(s2) Then s = s2: s2 = s1: s1 = s
   
5.     If n > 0 Then R = n Else R = 1
   
6.     i = 1
   
7.     f = ""
   
8.     Do While i <= Len(s1) - n + 1
   
9.         r0 = 0
   
10.         For j = R To Len(s1)
    
11.             s = Mid(s1, i, j): m = InStr(s2, s)
    
12.             If m Then
    
13.                 If Len(s) > R Then R = Len(s): f = s
    
14.                 r0 = 1
    
15.             Else
    
16.                 Exit For
    
17.             End If
    
18.         Next
    
19.         If r0 = 0 Then i = i + 1 Else i = i + R + 1
    
20.     Loop
    
21.     If n = 0 Then f = Len(f)
    
22. End Function
    

复制代码