如何用VBA提取多个字符串中相同部分

gddn

各位老师好：
　　遍寻不到答案，特开贴求教。我遇到的问题是这样的，假如有一列单元格，其中的内容如下：
　1.中国北京
　2.中国河北
　3.亚洲中国山西
　4.……中国……
　请问我如何用VBA来从这一列数据得到它们重叠的部分“中国”（在我不知道重叠字符串大小与内容，并且确定它们有重复内容的情况下），请各位老师指点。VBA中有这样的函数存在吗？
　谢谢dsmch 老师的提醒。

[ 本帖最后由 gddn 于 2010-12-10 11:06 编辑 ]

dsmch

把excel文件压缩上传，手工做个结果示意一下，方便大家帮你。

ericjon

Sub Test()
    Dim rge As Range
    Dim vt, i&
    Set rge = Range(Range("A3"), Range("A3").End(xlDown))
    vt = rge
    For i = 1 To UBound(vt)
        If vt(i, 1) Like "*" & "中国" & "*" Then
             vt(i, 1) = "中国"
        else  
             vt(i, 1) =""
        endif
    Next
    rge.Offset(0, 1) = vt
End Sub

[ 本帖最后由 ericjon 于 2010-12-10 11:26 编辑 ]

alzeng

1. 
   
2. Sub GetSameWord()
   
3.     Dim Arr, i%, Str$, strTmp$
   
4. 
   
5.     Arr = Range("A3", [A3].End(4))
   
6.     Str = Join(Application.Transpose(Arr))
   
7.     For i = 1 To Len(Arr(1, 1))
   
8.         If Len(Str) - Len(Replace(Str, Mid(Arr(1, 1), i, 1), "")) = UBound(Arr) Then strTmp = strTmp & Mid(Arr(1, 1), i, 1)
   
9.     Next
   
10.    
    
11.     [B2] = strTmp
    
12. End Sub
    

复制代码

[ 本帖最后由 alzeng 于 2010-12-10 11:36 编辑 ]

alzeng

以上代码要求去除最后单元格的"……"。

gddn

谢谢ericjon老师，程序我理解了，请问如果我想要一段通用的程序（我想做成一个EXCEL中的按钮如附件截图中的），其功能是：如果两个（或者被选中的一列中的数个）单元格有按次序相同的字符串（最少两个），则以Msgbox的形式给出相同的字符串，否则返回“无相同字符串”，例如：如果选中我的上面附件中“中国河北”与“亚洲中国山西”然后点击按钮，则给出消息框“重复字符串为：中国”。如果我选中的是“中国河北”与“亚洲国中”则给出的消息框为“无相同字符串”
不知道我叙述的是否足够清楚。

[ 本帖最后由 gddn 于 2010-12-10 11:45 编辑 ]

ericjon

我理解错你的意思了，你参考下4楼代码吧

gddn

谢谢一念老师，一词一词拆分后终于搞懂了其中的逻辑，对您的代码的精简与思路的开阔佩服的五体投地，膜拜！

gddn

呵呵，从你的代码中学习了不少东西呢（我是录制宏入的VBA，所以自己写的往往十分生硬），同样谢谢您的热心解答。

dsmch

一念老师的代码如果有重复的部分，就会出现遗漏。
用笨办法写了一个
Dim arr
arr = Range("a3:a" & Range("a65536").End(xlUp).Row)
x = 1000
For i = 1 To UBound(arr)
y = Len(arr(i, 1))
If Len(arr(i, 1)) < x Then m = x: x = y: y = m
Next i
For i = 1 To UBound(arr)
If Len(arr(i, 1)) = x Then z = arr(i, 1): Exit For
Next i
For i = Len(z) To 1 Step -1
For k = 1 To Len(z) - i + 1
b = Mid(z, k, i)
s = 0
For j = 1 To UBound(arr)
If InStr(arr(j, 1), b) > 0 Then s = s + 1
Next j
If s = UBound(arr) Then Range("b2") = b: Exit Sub
Next k
Next i