那位老师帮助弄一下

吴虾咪

像这样的，里面有个以前是也是老师弄的。大概差不多，就是改了所要的样式。

ykcbf1100

你这个鹅蛋是很难区分的，因为词根中既有蛋，又有鹅，还有鹅蛋。在搜索时，先搜到蛋，所以，先标记为蛋。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.5.23
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("词根")
   
4.         arr = .UsedRange
   
5.         For i = 2 To UBound(arr)
   
6.             For j = 1 To UBound(arr, 2)
   
7.                 S = arr(i, j)
   
8.                 If S <> Empty Then
   
9.                     d(S) = ""
   
10.                 End If
    
11.             Next
    
12.         Next
    
13.     End With
    
14.     With Sheets("数据")
    
15.         arr = .UsedRange
    
16.         .UsedRange.Offset(1).Interior.ColorIndex = 0
    
17.         .[d2:d1000] = ""
    
18.         For i = 2 To UBound(arr)
    
19.             For Each k In d.keys
    
20.                 t = InStr(arr(i, 3), k)
    
21.                 If t Then
    
22.                     .Cells(i, 4) = k
    
23.                     With .Cells(i, 3).Characters(t, Len(k)).Font
    
24.                         .ColorIndex = 3
    
25.                     End With
    
26.                     Exit For
    
27.                 End If
    
28.             Next
    
29.         Next
    
30.     End With
    
31. End Sub
    
32. 
    

复制代码

吴虾咪

ykcbf1100 发表于 2024-5-23 16:35
参与一下。。。

1、老师哪碰到，+ = - # 就停止运行，这样的保以屏蔽不。忽略过不。

2、还有 比如蛋词根我就把词根表里面的蛋更换别的。执行后数据还是提取蛋.试好了好几次都是一样。我这词根有2000多个，是不是出问题了。

LIUZHU

这个效果是不？

LIUZHU

JSA代码，供参考

1. function 匹配(){
   
2.         let arr=Sheets.Item("词根").Range("a1").CurrentRegion.Value2;
   
3.         let findarr=arr.slice(1).reduce((findarr,x)=>{
   
4.                 x.forEach(y=>y!=null?findarr.push(y):null);
   
5.                 return findarr;
   
6.         },[]);
   
7.         let temp=Range("c1:c" + Range("c"+ Rows.Count).End(xlUp).Row).Value2;
   
8.         let res=temp.reduce((res,[x],i)=>{
   
9.                 if (i<1) return res;
   
10.                 res[i]=[], start=x.length, len=x.length;
    
11.                 findarr.forEach((y,j)=>{
    
12.                         if (!x.includes(y)) return;
    
13.                         let n=x.indexOf(y) + 1;
    
14.                         if (n<=start && y.length<=len){
    
15.                                 res[i]=[y];
    
16.                                 [start, len]=[n, y.length];
    
17.                                 Cells.Item(i+1,3).Font.Color=0;
    
18.                                 Cells.Item(i+1,3).Characters(start,len).Font.Color=255;
    
19.                         }
    
20.                 });
    
21.                 return res;
    
22.         },[["提取所包含的词根"]]);
    
23.         Range("d1").Resize(res.length,1).Value2=res;
    
24. }

复制代码

LIUZHU

附件在此，WPS打开测试

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar(), i&, j&, strJoin$, t#
   
    Application.ScreenUpdating = True
    t = Timer
    ar = Sheets(1).[A1].CurrentRegion.Value
   
    With CreateObject("VBScript.RegExp")
        .Global = True
        For j = 1 To UBound(ar, 2)
            For i = 2 To UBound(ar, 2)
                If Len(ar(i, j)) Then strJoin = strJoin & "|" & ar(i, j)
            Next i
        Next j
        .Pattern = Mid(strJoin, 2)
        ar = Range("C2", Cells(Rows.Count, "C").End(xlUp)).Value
        For i = 1 To UBound(ar)
            If .test(ar(i, 1)) Then
                ar(i, 1) = .Execute(ar(i, 1))(0).Value
            Else
                ar(i, 1) = Empty
            End If
        Next i
    End With

    [D2].Resize(UBound(ar)) = ar
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

请参考。。。

山菊花

供参考。