对比两单元格字符不同的用颜色标注出来

大雨治水

前些天关注了一下由简称查找全称、用于了对比字符串的相似度(或叫雷同度)，并需要对不同的部分进行标注，如下图，

需要对比A列与B列的不同的字符，并标注成红色：






我找了许多代码，没有得到好的方案，研究了几天，做用了论坛的一个自定义函数，自己再加上几句代码，基本解决了这个问题：



代码不是很完善，只是达到的基本效果，大家有兴趣的可以完善一下，并分享之，谢谢！

代码如下：

1. Sub 标注不同字符()
   
2.     Dim myrow%, i%, j%, n%, m%, s%
   
3.     Dim str$, s1$, s2$, s3$
   
4.     Dim strA$, strB$
   
5. 
   
6.     On Error Resume Next
   
7. 
   
8.     Call 恢复颜色
   
9. 
   
10.     ''将区域设置为文本格式
    
11.     Columns("A:B").NumberFormatLocal = "@"
    
12. 
    
13.     myrow = Range("A65536").End(xlUp).Row
    
14. 
    
15.     For i = 2 To myrow
    
16.         ''先修改全部字符串的颜色
    
17.         Cells(i, 1).Font.Color = vbRed
    
18.         Cells(i, 2).Font.Color = vbRed
    
19. 
    
20.         strA = Cells(i, 1).Value
    
21.         strB = Cells(i, 2).Value
    
22. 
    
23.         ''提取最大相同字符串
    
24.         s1 = xt(strA, strB)
    
25. abc:
    
26.         m = Len(s1)
    
27.         n = InStr(1, Cells(i, 1).Value, s1)
    
28.         ''.Characters(Start:=1, Length:=1).Font....
    
29.         Cells(i, 1).Characters(n, m).Font.ColorIndex = vbBlack    '改成黑色
    
30. 
    
31.         n = InStr(1, Cells(i, 2).Value, s1)
    
32.         Cells(i, 2).Characters(n, m).Font.ColorIndex = vbBlack    '改成黑色
    
33. 
    
34. 
    
35.         ''去除相同内容后，再提取相同内容
    
36.         strA = Replace(strA, s1, "")
    
37.         strB = Replace(strB, s1, "")
    
38.         If StrReverse(strA) <> strB Then
    
39.             If Len(strA) >= 2 And Len(strB) >= 2 Then
    
40.                 ''提取最大相同字符串
    
41.                 s1 = xt(strA, strB)
    
42.                 If s1 <> "" Then
    
43.                     GoTo abc
    
44.                 End If
    
45.             End If
    
46.         End If
    
47.         m = 0
    
48.         n = 0
    
49. 
    
50.     Next i
    
51. 
    
52. End Sub

复制代码

下面这段求最大相同字符串的自定义函数是论坛找到的：

1. Function xt(rng1, rng2)
   
2. ''最大相同部分
   
3.     Dim n%, j%, i%
   
4.     zf = LCase(rng1)
   
5.     zf2 = LCase(rng2)
   
6.     p = ""
   
7.     n = Len(zf)
   
8.     For i = n To 1 Step -1
   
9.         For j = 1 To n - i + 1
   
10.             z = Mid(zf, j, i)
    
11.             If InStr(zf2, z) Then
    
12.                 p = z
    
13.                 GoTo 100
    
14.             End If
    
15.         Next
    
16.     Next
    
17. 100:
    
18.     xt = p
    
19. End Function

复制代码

这个代码是调试用的，用于恢复字体颜色为黑色，可有可无：

1. Sub 恢复颜色()
   
2.     Cells.Font.ColorIndex = 0
   
3. End Sub

复制代码

附件下载：

找出两个单元格中不同的字符并用颜色标示出来--谢顺胜.zip (13.65 KB, 下载次数: 337)

2017-12-13 13:31 上传

点击文件名下载附件

补充内容 (2018-8-21 15:56):
修改了一下，把最新的代码上传一下：

附件见14楼！

大雨治水

奇怪，明明有点贴子，怎么在论坛搜索找不到！

大雨治水

这个标题是不是有点偏僻？怎么有人下载没人回复讨论呢

大雨治水

还是自己路过一下先！

shyy1989

请问大神，用您的代码之后我要对比的数据A列和B列的内容特别多，excel一直跑圈圈，怎么解决呢？

shyy1989

左右数据的字符串长度有123个，就会一直打圈圈555555555555

shyy1989

我把整形改为长整型了，还是不行啊

大雨治水

shyy1989 发表于 2018-1-12 00:19
我把整形改为长整型了，还是不行啊

把你的附件传上来，我测试一下看看！

heishe520

大雨治水 发表于 2017-12-24 15:36
还是自己路过一下先！

大神，代码挺好用，但是数据多一点就卡死啊，能否看一下什么原因。。

wmj1999

好，谢谢提供，正需要！