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

skyskyabc

大雨治水 发表于 2018-8-21 15:55
修改了一下，把最新的代码上传一下：

下载下来的压缩包，里面excel的格式是xls.代码都丢失了。请问能post出来吗？

大雨治水

skyskyabc 发表于 2019-11-10 14:55
下载下来的压缩包，里面excel的格式是xls.代码都丢失了。请问能post出来吗？

我下载了一楼的代码，没有问题呀？

1. <div><div>Sub 恢复颜色()</div><div>    Cells.Font.ColorIndex = 0</div><div>End Sub</div><div>
   
2. </div><div>Sub 标注不同字符()</div><div>    Dim myrow%, i%, j%, n%, m%, s%</div><div>    Dim str$, s1$, s2$, s3$</div><div>    Dim strA$, strB$</div><div>
   
3. </div><div>    On Error Resume Next</div><div>
   
4. </div><div>    Call 恢复颜色</div><div>
   
5. </div><div>    ''将区域设置为文本格式</div><div>    Columns("A:B").NumberFormatLocal = "@"</div><div>
   
6. </div><div>    myrow = Range("A65536").End(xlUp).Row</div><div>
   
7. </div><div>    For i = 2 To myrow</div><div>        ''先修改全部字符串的颜色</div><div>        Cells(i, 1).Font.Color = vbRed</div><div>        Cells(i, 2).Font.Color = vbRed</div><div>
   
8. </div><div>        strA = Cells(i, 1).Value</div><div>        strB = Cells(i, 2).Value</div><div>
   
9. </div><div>        ''提取最大相同字符串</div><div>        s1 = xt(strA, strB)</div><div>abc:</div><div>        m = Len(s1)</div><div>        n = InStr(1, Cells(i, 1).Value, s1)</div><div>        ''.Characters(Start:=1, Length:=1).Font....</div><div>        Cells(i, 1).Characters(n, m).Font.ColorIndex = vbBlack    '改成黑色</div><div>
   
10. </div><div>        n = InStr(1, Cells(i, 2).Value, s1)</div><div>        Cells(i, 2).Characters(n, m).Font.ColorIndex = vbBlack    '改成黑色</div><div>
    
11. </div><div>
    
12. </div><div>        ''去除相同内容后，再提取相同内容</div><div>        strA = Replace(strA, s1, "")</div><div>        strB = Replace(strB, s1, "")</div><div>        If StrReverse(strA) <> strB Then</div><div>            If Len(strA) >= 2 And Len(strB) >= 2 Then</div><div>                ''提取最大相同字符串</div><div>                s1 = xt(strA, strB)</div><div>                If s1 <> "" Then</div><div>                    GoTo abc</div><div>                End If</div><div>            End If</div><div>        End If</div><div>        m = 0</div><div>        n = 0</div><div>
    
13. </div><div>    Next i</div><div>
    
14. </div><div>End Sub</div><div>
    
15. </div><div>Function xt(rng1, rng2)</div><div>''最大相同部分</div><div>    Dim n%, j%, i%</div><div>    zf = LCase(rng1)</div><div>    zf2 = LCase(rng2)</div><div>    p = ""</div><div>    n = Len(zf)</div><div>    For i = n To 1 Step -1</div><div>        For j = 1 To n - i + 1</div><div>            z = Mid(zf, j, i)</div><div>            If InStr(zf2, z) Then</div><div>                p = z</div><div>                GoTo 100</div><div>            End If</div><div>        Next</div><div>    Next</div><div>100:</div><div>    xt = p</div><div>End Function</div></div><div></div>

复制代码

YZC51

大雨治水 发表于 2020-2-6 16:30
我下载了一楼的代码，没有问题呀？

整理下
Sub 恢复颜色()
    Cells.Font.ColorIndex = 0
End Sub

Sub 标注不同字符()
    Dim myrow%, i%, j%, n%, m%, s%
    Dim str$, s1$, s2$, s3$
    Dim strA$, strB$
    On Error Resume Next
    Call 恢复颜色
    Columns("A:B").NumberFormatLocal = "@"
    myrow = Range("A65536").End(xlUp).Row
    For i = 2 To myrow
        Cells(i, 1).Font.Color = vbRed
        Cells(i, 2).Font.Color = vbRed
        strA = Cells(i, 1).Value
        strB = Cells(i, 2).Value
        s1 = xt(strA, strB)
        abc:
        m = Len(s1)
        n = InStr(1, Cells(i, 1).Value, s1)
        Cells(i, 1).Characters(n, m).Font.ColorIndex = vbBlack
        n = InStr(1, Cells(i, 2).Value, s1)
        Cells(i, 2).Characters(n, m).Font.ColorIndex = vbBlack
        strA = Replace(strA, s1, "")
        strB = Replace(strB, s1, "")
        If StrReverse(strA) <> strB Then
            If Len(strA) >= 2 And Len(strB) >= 2 Then
                s1 = xt(strA, strB)
                If s1 <> "" Then
                    GoTo abc
                End If
            End If
        End If
        m = 0
        n = 0
    Next i
End Sub

Function xt(rng1, rng2)
    Dim n%, j%, i%
    zf = LCase(rng1)
    zf2 = LCase(rng2)
    p = ""
    n = Len(zf)
    For i = n To 1 Step -1
        For j = 1 To n - i + 1
            z = Mid(zf, j, i)
            If InStr(zf2, z) Then
                p = z
                GoTo 100
            End If
        Next
    Next
    100:
    xt = p
End Function

lanbing021

大神厉害，一下子解决个大问题。

不过，我刚才测试了一下，我把想相同位置的字符相比较，
比如第一列的第一个字符和第二列的第一个字符比较，需要改哪个代码

excel-ssy01

大雨治水 发表于 2018-9-2 19:50
具体截图说明一下！

比如我增加倒数两行的数据A和B，A完全不=B，但是A和B两个字符串都没有被标记成红色，能否修改下代码，让两个单元格中没有出现相同的字符时，让他们两个单元格里的字符串都被标成红色，或者蓝色。
还请老师帮帮忙，谢谢啦！

blackttea1

关注下，学习啦

lukeforall

1. 
   

复制代码

我写了个类似的编码，应该可以完美解决大家的类似问题，大家只需修改 columnA 和  columnB 的列号, rowNum 首行，就可以了楼主的代码我也看了，简单的比较没有问题，但是会出现抽取的最大字串是合并后的字段的问题，也没有比较单字，相同文字但调换位置的修改不会高亮。

大家可以试下我的代码，有问题讨论

1. 
   
2. Type MatchStruct
   
3. substrText As String
   
4. posAstart As Integer
   
5. posBstart As Integer
   
6. posAend As Integer
   
7. posBend As Integer
   
8. substrLength As Integer
   
9. substrMatch As Boolean
   
10. End Type
    
11. 
    
12. Sub HighlightDiff()
    
13. Dim columnA%, columnB%, rowNum%, rowMax%, i%, j%, posTmp%, temp%
    
14. Dim strA$, strB$, substr$
    
15. Dim substrList(5000) As MatchStruct
    
16. Dim matchCount As Integer
    
17. 
    
18. On Error Resume Next
    
19. 
    
20. columnA = 1 'Index for current translation column
    
21. columnB = 2 'Index for suggested translation column
    
22. rowNum = 2 'Index for the first row to compare
    
23. 'Format the range as red
    
24. 
    
25. rowMax = Range("A65536").End(xlUp).Row
    
26. Range(Cells(2, columnA), Cells(rowMax, columnA)).Font.Color = vbRed
    
27. Range(Cells(2, columnB), Cells(rowMax, columnB)).Font.Color = vbRed
    
28. 
    
29. For rowNum = 2 To rowMax
    
30. 'skip blank rows
    
31. If Len(Cells(rowNum, columnA).Text) = 0 Or Len(Cells(rowNum, columnB).Text) = 0 Then rowNum = rowNum + 1
    
32. 
    
33. 'Extract longest to shortest common strings,and store their positions
    
34. strA = LCase(Cells(rowNum, columnA).Value)
    
35. strB = LCase(Cells(rowNum, columnB).Value)
    
36. n = Len(strA)
    
37. matchCount = 1
    
38. For i = n To 1 Step -1
    
39. For j = 1 To n - i + 1
    
40. substr = Mid(strA, j, i)
    
41. posTmp = InStr(strB, substr)
    
42. If posTmp > 0 Then
    
43. strA = Replace(strA, substr, String(i, "犇"), 1, 1, vbTextCompare)
    
44. strB = Replace(strB, substr, String(i, "淼"), 1, 1, vbTextCompare)
    
45. substrList(matchCount).substrMatch = True
    
46. substrList(matchCount).substrText = substr
    
47. substrList(matchCount).substrLength = i
    
48. substrList(matchCount).posAstart = j
    
49. substrList(matchCount).posBstart = posTmp
    
50. substrList(matchCount).posAend = j + i - 1
    
51. substrList(matchCount).posBend = posTmp + i - 1
    
52. matchCount = matchCount + 1
    
53. End If
    
54. Next j
    
55. Next i
    
56. 
    
57. 'Check if the matches are in their original order, matches that are in different order will stay in red
    
58. For i = 1 To matchCount - 1
    
59. For j = 1 To i
    
60. If substrList(i).posAend < substrList(j).posAstart And substrList(i).posBstart > substrList(j).posBend Or substrList(i).posAstart > substrList(j).posAend And substrList(i).posBend < substrList(j).posBstart Then
    
61. substrList(i).substrMatch = False
    
62. Exit For
    
63. End If
    
64. Next j
    
65. Next i
    
66. 
    
67. 'Set matched words back to black
    
68. For i = 1 To matchCount - 1
    
69. If substrList(i).substrMatch = True Then
    
70. Cells(rowNum, columnA).Characters(substrList(i).posAstart, substrList(i).substrLength).Font.Color = vbBlack
    
71. Cells(rowNum, columnB).Characters(substrList(i).posBstart, substrList(i).substrLength).Font.Color = vbBlack
    
72. End If
    
73. Next
    
74. 
    
75. Next rowNum
    
76. 
    
77. End Sub

复制代码

lukeforall

excel-ssy01 发表于 2020-8-26 11:30
比如我增加倒数两行的数据A和B，A完全不=B，但是A和B两个字符串都没有被标记成红色，能否修改下代码，让 ...

用我的代码就可以解决，楼主的代码不比较一个字符

excel-ssy01

lukeforall 发表于 2020-9-9 12:04
用我的代码就可以解决，楼主的代码不比较一个字符

太感谢了，大师。

2735300630

大神，你的这个帖子， https://club.excelhome.net/thread-1384696-3-3.html

能不能把相同的标红啊？急用，万分感谢，能不能发个弄好的表格，