学习Excel技术，关注微信公众号：
excelperfect
标签：
AI
，
大模型
，
deepseek
，
VBA
在《
使用deepseek给Excel工作表两列相同汉字标记颜色
》中，
deepseek
给出的
VBA
代码分别给两列中相同的汉字标记不同的颜色，即便连续汉字内容相同；随后，在《
使用deepseek给Excel工作表两列相同的连续汉字标记颜色
》中，
deepseek
给出的代码可以给两列连续汉字标记相同颜色；然而，如果同一单元格中有
2
个或多个相同的连续内容，
deepseek
在前面给出的代码均不能解决，为此，我们接着向
deepseek
提问以完善代码。
向
deepseek
提问如下：
如果两列单元格中的某个单元格中有两个或多个相同的连续内容，也应标记为相同的颜色，例如列
A
中是
“
北京北京
”
，列
B
中是
“
上海北京
”
，则列
A
中的两个
“
北京
”
和列
B
中的一个
“
北京
”
都应标记为相同的颜色，请修改代码。
下面是
deepseek
给出的代码：
Sub ColorCommonCharacters() Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 颜色池（可自定义修改） Dim colors() As Variant colors = Array(&HFF0000, &HFF00, &HFF, &HFFFF00, &HFF00FF, &HFFFF, &H808000, &H800080, &H808080) Dim colorDict As Object Set colorDict = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False ' 遍历每一行 Dim i As Long For i = 1 To lastRow Dim cellA As Range, cellB As Range Set cellA = ws.Cells(i, "A") Set cellB = ws.Cells(i, "B") ' 查找最长公共子串 Dim commonStr As String commonStr = FindLongestCommonSubstring(cellA.Value, cellB.Value) If commonStr <> "" Then ' 分配颜色 If Not colorDict.Exists(commonStr) Then colorDict(commonStr) = colors(colorDict.Count Mod (UBound(colors) + 1)) End If ' 应用颜色格式 ColorizeText cellA, commonStr, colorDict(commonStr) ColorizeText cellB, commonStr, colorDict(commonStr) End If Next i Application.ScreenUpdating = True MsgBox "处理完成！"End Sub
Function FindLongestCommonSubstring(strA As String, strB As String) As String Dim maxLen As Long maxLen = 0 Dim result As String Dim dp() As Long ReDim dp(Len(strA), Len(strB)) Dim i As Long, j As Long For i = 1 To Len(strA) For j = 1 To Len(strB) If Mid(strA, i, 1) = Mid(strB, j, 1) Then dp(i, j) = dp(i - 1, j - 1) + 1 If dp(i, j) > maxLen Then maxLen = dp(i, j) result = Mid(strA, i - maxLen + 1, maxLen) End If Else dp(i, j) = 0 End If Next j Next i FindLongestCommonSubstring = resultEnd Function
Sub ColorizeText(cell As Range, commonStr As String, color As Long) With cell.Font .color = vbBlack ' 重置颜色 Dim pos As Long pos = 1 Do While pos > 0 pos = InStr(pos, cell.Value, commonStr) If pos > 0 Then cell.Characters(pos, Len(commonStr)).Font.color = color pos = pos + Len(commonStr) ' 跳过已标记部分 End If Loop End WithEnd Sub
在示例工作表中运行
ColorCommonCharacters
过程，效果如下图
1
