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

lionzhong

我试了一下4楼老师的代码，我想引用单元表2作为数据源，改了其中一句后就不能运行了，具体修改为 Arr = Worksheets(2).Range("A3", [A3].End(4))
各位老师，请问应该怎么操作啊？也就是改为如下情况：
Sub GetSameWord()
    Dim Arr, i%, Str$, strTmp$
    Arr = Worksheets(2).Range("A3", [A3].End(4))
    Str = Join(Application.Transpose(Arr))
    For i = 1 To Len(Arr(1, 1))
        If Len(Str) - Len(Replace(Str, Mid(Arr(1, 1), i, 1), "")) = UBound(Arr) Then strTmp = strTmp & Mid(Arr(1, 1), i, 1)
    Next
    [B2] = strTmp
End Sub

lionzhong

求助求助，不能让此贴沉下去！

lionzhong

求助求助！！

HHAAMM

是这个意思吗

1. Public Sub Most()
   
2.     Dim d As Object
   
3.     Dim arr As Variant
   
4.     Dim strKey As Variant
   
5.     Dim strItem As Variant
   
6.     Dim strArr() As String, m$, m1$
   
7.     Dim tr(1 To 2) As Integer
   
8.     Dim ttr() As Integer
   
9.     Dim l%, r%, x%, i%, j%
   
10.     Dim blnP As Boolean
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     r = [A65536].End(xlUp).Row
    
13.     arr = Range("A1:A" & r)
    
14.     For l = 2 To 5
    
15.         ReDim strArr(1 To r)
    
16.         tr(1) = 1
    
17.         For x = 1 To r
    
18.             tr(2) = x
    
19.             For i = 1 To Len(arr(x, 1))
    
20.                 blnP = True
    
21.                 m = Mid(arr(x, 1), i, l)
    
22.                 If Len(m) = l Then
    
23.                     For j = 1 To l
    
24.                         m1 = Mid(m, j, 1)
    
25.                         If Not (Asc(m1) > -20319 And Asc(m1) < -2050) Then
    
26.                             blnP = False
    
27.                             Exit For
    
28.                         End If
    
29.                     Next
    
30.                     If blnP Then
    
31.                         If d.Exists(m) Then
    
32.                             ttr = d(m)
    
33.                             If ttr(2) <> x Then
    
34.                                 ttr(1) = ttr(1) + 1
    
35.                                 ttr(2) = x
    
36.                                 d(m) = ttr
    
37.                             End If
    
38.                         Else
    
39.                             d(m) = tr
    
40.                         End If
    
41.                     End If
    
42.                 End If
    
43.             Next
    
44.         Next
    
45.         strKey = d.keys
    
46.         strItem = d.items
    
47.         d.RemoveAll
    
48.         tr(1) = 0
    
49.         tr(2) = 0
    
50.         For x = 0 To UBound(strItem)
    
51.             If strItem(x)(1) >= tr(1) Then
    
52.                 tr(1) = strItem(x)(1)
    
53.                 tr(2) = x
    
54.             End If
    
55.         Next
    
56.         If tr(1) > 1 Then
    
57.             Cells(l, 2).Value = l & "个的词"
    
58.             Cells(l, 3).Value = strKey(tr(2))
    
59.             Cells(l, 4).Value = "出现次数 " & tr(1)
    
60.         End If
    
61.     Next
    
62. End Sub

复制代码

lionzhong

好复杂喔，我试了四楼老师的代码可以运行，但他的代码只针对所有数据都在同一个工作表中，我的意思是对比的数据在sheet2，答案显示在sheet1.  好像附件这样。

yjh_27

lionzhong 发表于 2014-3-22 14:59
求助求助！！

移步


雷同字符提取函数 自定义函数 20L
http://club.excelhome.net/thread-883745-1-1.html

alzeng

lionzhong 发表于 2014-3-22 13:31
我试了一下4楼老师的代码，我想引用单元表2作为数据源，改了其中一句后就不能运行了，具体修改为 Arr = Wor ...

Sub GetSameWord()
    Dim Arr, i%, Str$, strTmp$

    Arr = Sheets(2).Range("A3", Sheets(2).[A3].End(4))
    Str = Join(Application.Transpose(Arr))
    For i = 1 To Len(Arr(1, 1))
        If Len(Str) - Len(Replace(Str, Mid(Arr(1, 1), i, 1), "")) = UBound(Arr) Then strTmp = strTmp & Mid(Arr(1, 1), i, 1)
    Next

    Sheets(1).[B2] = strTmp
End Sub