查找某列的词是否包含于另一列

abc0931

如附件所示

sheet1的第一列列出了很多词，可能多达上千个。
现在要把sheet2中的第一列的几十个字或词，依次查看每一个是否包含于sheet1的A列中的某个词中，如果发现包含，则把sheet1中发现的词依次列于sheet2的E1单元格下面。
不知是否可以实现？哪位高手出手相助！深表感谢！！

fzxba

1. Sub test1()
   
2.   Dim ar, br, i As Long, r As Long
   
3.   
   
4.   Sheet2.Activate
   
5.   br = WorksheetFunction.Transpose(Range("A2", Cells(Rows.Count, "A").End(xlUp)))
   
6.   ar = Sheet1.Range("A1").CurrentRegion.Columns(1)
   
7.   With CreateObject("VBScript.RegExp")
   
8.     .Global = True
   
9.     .Pattern = Join(br, "|")
   
10.     For i = 1 To UBound(ar)
    
11.       If .Test(ar(i, 1)) Then
    
12.         r = r + 1
    
13.         ar(r, 1) = ar(i, 1)
    
14.       End If
    
15.     Next
    
16.   End With
    
17.   
    
18.   If r Then
    
19.     With Range("E2")
    
20.       .Resize(UBound(ar)).ClearContents
    
21.       .Resize(r) = ar
    
22.     End With
    
23.   End If
    
24.   
    
25. End Sub

复制代码

taller

fzxba

工作簿2.zip (17.95 KB, 下载次数: 13)

2024-2-24 11:21 上传

点击文件名下载附件

x-xx-xx

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.2.24
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet2")
   
6.         r = .Cells(Rows.Count, "a").End(xlUp).Row
   
7.         zrr = .[a1].Resize(r, 1)
   
8.     End With
   
9.     For i = 2 To UBound(zrr)
   
10.         s = zrr(i, 1)
    
11.         d(s) = ""
    
12.     Next
    
13.     With Sheets("Sheet1")
    
14.         r = .Cells(Rows.Count, "a").End(xlUp).Row
    
15.         arr = .[a1].Resize(r, 1)
    
16.         ReDim brr(1 To UBound(arr), 1 To 1)
    
17.         For i = 1 To UBound(arr)
    
18.             s = arr(i, 1)
    
19.             For Each k In d.keys
    
20.                 If InStr(s, k) Then
    
21.                     m = m + 1
    
22.                     brr(m, 1) = arr(i, 1)
    
23.                 End If
    
24.             Next
    
25.         Next
    
26.     End With
    
27.     With Sheets("Sheet2")
    
28.         .[e2:e1000] = ""
    
29.         .[e2].Resize(m, 1) = brr
    
30.     End With
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    

复制代码

yanglinzi

1. Sub 查词()
   
2. Dim arr, brr, d, i, j, r
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.UsedRange
   
5. For i = 1 To UBound(arr)
   
6.     s = arr(i, 1)
   
7.     d(s) = ""
   
8. Next
   
9. brr = Sheet2.UsedRange
   
10. Sheet2.[e2:e1000].Clear
    
11. For j = 2 To UBound(brr)
    
12.     s = brr(j, 1)
    
13.     For Each k In d.keys
    
14.         If InStr(k, s) > 0 Then
    
15.             Sheet2.Cells(j, "e") = Sheet2.Cells(j, "e") & "," & k
    
16.         End If
    
17.     Next
    
18.     Sheet2.Cells(j, "e") = Mid(Sheet2.Cells(j, "e"), 2)
    
19. Next
    
20. End Sub

复制代码

yanglinzi

参与一下。。

abc0931

竟然来了这么多老师参与，全都下载下来慢慢学习。
深表感谢！！！