用字典法来进行包含匹配

gufengaoyue

jacksc 发表于 2014-5-29 12:54
老师：用此方法可以了，但却耗时近300秒，不知还有更简洁快速的办法没？谢谢！

试了几次，大概43秒左右。

1. Sub 匹配()
   
2. 'On Error Resume Next
   
3. 'Dim arr, D, a&, x&, t#, MyStr$
   
4.     t = Timer    '开始记时
   
5.     Application.ScreenUpdating = False            '关闭屏幕闪烁
   
6.     Range("C2:C65536").ClearContents             '清除数据
   
7.     Set D = CreateObject("scripting.dictionary")
   
8.     arr = Sheet2.Range("b2:b" & Sheet2.Range("b65536").End(xlUp).Row)
   
9.     For a = 1 To UBound(arr)
   
10. '        If Len(arr(a, 1)) > 0 Then             '如果有空白的，打开这里
    
11.             l = l + Len(arr(a, 1))
    
12.             D(l) = arr(a, 1)
    
13. '        End If
    
14.     Next
    
15.     arr = Range("b2:c" & Range("b65536").End(xlUp).Row)
    
16.     MyStr = Join(D.items(), "|") & "|"
    
17.     For a = 1 To UBound(arr)
    
18.         If arr(a, 1) <> "" Then
    
19.             x = InStr(InStr(1, MyStr, arr(a, 1)), MyStr, "|")
    
20.             x = x - (x - Len(Replace(Left(MyStr, x), "|", "")))
    
21.             arr(a, 2) = D(x)
    
22.         Else
    
23.             arr(a, 2) = "没找到数据"
    
24.         End If
    
25.     Next
    
26.     Range("b2:c" & Range("b65536").End(xlUp).Row) = arr
    
27.     Application.ScreenUpdating = True            '还原屏幕闪烁
    
28.     MsgBox "匹配完成；共用时" & Format(Timer - t, "0.00秒。")
    
29. End Sub
    

复制代码

bluexuemei

jacksc 发表于 2014-5-29 14:57
老师：有的，都可包含匹配的，蓝老师的代码就可以的。另：我附件中的描述不准确，sheet1表页的 C列应该是 ...

我理解错你的意思了，稍等

1. Sub 匹配()
   
2.     t = Timer    '开始记时
   
3.     r = Sheet1.Range("c65536").End(xlUp).Row
   
4.     arr = Sheet1.Range("a2:c" & r)
   
5.     s = Join(Application.Transpose(Sheet1.Range("c2:c" & r)))
   
6.     For i = 1 To UBound(arr)
   
7.        If arr(i, 2) = "" Then
   
8.          arr(i, 1) = ""
   
9.        ElseIf InStr(s, arr(i, 2)) Then
   
10.          arr(i, 1) = arr(i, 3)
    
11.        End If
    
12.     Next
    
13.     Sheet1.Range("a2:a" & r) = arr
    
14.     MsgBox "匹配完成；共用时" & Format(Timer - t, "0.00秒。")
    
15.     'Stop
    
16. End Sub

复制代码

zax010

jacksc 发表于 2014-5-29 14:44
老师：我附件中的描述不准确，sheet1表页的 C列应该是 sheet2表页的B列，请再看看，谢谢！

数据取自Sheet2，改了代码，提高了一些速度：
Sub zz()
    t = Timer
    arr = Sheet2.Range("B2:B" & Sheet2.Range("B65536").End(xlUp).Row)
    brr = Sheet1.Range("B2:B" & Sheet1.Range("B65536").End(xlUp).Row)
    ReDim crr(1 To UBound(brr), 1 To 1)
    For j = 1 To UBound(brr)
        If brr(j, 1) <> "" Then
            For i = 1 To UBound(arr)
                If InStr(arr(i, 1), brr(j, 1)) Then
                    crr(j, 1) = arr(i, 1)
                    Exit For
                End If
            Next
        End If
    Next
    Range("A2").Resize(UBound(brr), 1) = crr
    MsgBox "匹配完成；共用时" & Format(Timer - t, "0.00秒。")
End Sub

MRHUANGHESIR

學習了，字典真好，但難學哦

ysjhxh

蓝桥玄霜 发表于 2014-5-29 11:20
请见附件。

Sub 匹配()
    t = Timer    '开始记时
    Application.ScreenUpdating = False            '关闭屏幕闪烁
    Range("a2:a65536").ClearContents             '清除数据
    Set d = CreateObject("scripting.dictionary")
    r = Range("c65536").End(xlUp).Row
    arr = Range("a2:c" & r)
    For i = 1 To UBound(arr)
        d(arr(i, 3)) = ""
    Next
    k = d.keys
    For i = 1 To UBound(arr)
    For j = 0 To UBound(k)
        If arr(i, 2) <> "" Then
        If InStr(k(j), arr(i, 2)) Then
            arr(i, 1) = k(j): GoTo 100
        End If
        Else
            arr(i, 1) = "": GoTo 100
        End If
    Next
    arr(i, 1) = "没有找到数据！"
100:
    Next
    [a2].Resize(UBound(arr), 1) = Application.Index(arr, 0, 1)
    Application.ScreenUpdating = True            '还原屏幕闪烁
    MsgBox "匹配完成；共用时" & Format(Timer - t, "0.00秒。")
End Sub

蓝版，请问
    For i = 1 To UBound(arr)
        d(arr(i, 3)) = ""
该怎么理解？如果想理解您这段字典代码，有什么参考的教程吗？

蓝桥玄霜

ysjhxh 发表于 2016-12-15 09:59
Sub 匹配()
    t = Timer    '开始记时
    Application.ScreenUpdating = False            '关闭屏 ...

常见字典用法集锦及代码详解
http://club.excelhome.net/thread-868892-1-1.html

LMY123

字典和数组模糊匹配

02761752696

学习学习，谢谢分享

chengw823

蓝桥玄霜 发表于 2014-5-29 11:19

老师，除了循环，请问有没有直接的办法？