回复：急求大神，怎么把多列文本都出现的重复值标记不同颜色

我觉得标记颜色有局限性，颜色多了看花眼啊，应该将符合条件的值和对应的单元格地址生成在一个单独的表格里，并添加超链接之类的方便快速浏览。

基于我上面的代码，在标注颜色时把单元格地址等信息生成到一个表格里会方便一些吧。

'这一版新增了创建比对结果表的功能，并矫正了之前的代码

Sub 标记多个连贯列中的共同值()
Dim Na As String, qs As Range, q As Range, r As Long, c As Integer, _
rz As Long, cz As Integer, js As Integer, _
rd As Integer, a As Integer, g As Integer, _
t As Integer, cl As Double, n As Long, j As Integer, _
sz() As String, NB As Worksheet
On Error GoTo en
With ActiveWorkbook
For Each NB In .Worksheets
If InStr(1, NB.Name, "比对结果") > 0 Then
Application.DisplayAlerts = False
NB.Delete '删除比对结果表
Application.DisplayAlerts = True
End If
Next NB
End With
Na = ActiveSheet.Name '改成待比对的源数据表格名称
Set qs = Application.InputBox( _
"请选中数据区域左上角所在的单元格，然后点击确定", "起始参数设置：", Type:=8)
If qs = False Or qs.Cells.Count > 1 Then GoTo en
With Worksheets(Na)
Set q = .Range(qs.Address).CurrentRegion
.Select
'返回一个 Range 对象，该对象表示当前区域。当前区域是以空行与空列的组合为边界的区域。只读
With q
.Select
rz = .Rows.Count '总行数
cz = .Columns.Count '总列数
a = Application.InputBox( _
"你要从几个连贯的列中标记出它们的共同值？输入列数：", _
"提示：数据区域为" & .AddressLocal(0, 0), cz, , , , , 1)
If a = False Or a <= 0 Or a > cz Then GoTo en '不符合列的参数条件就结束
.Interior.Pattern = xlNone '清除填充的颜色
For r = 1 To rz
If Trim(.Cells(r, 1)) <> "" Then '只找非空值
For c = 2 To a
t = WorksheetFunction.CountIf(.Columns(c), .Cells(r, 1))
If t > 0 Then
js = js + 1 '统计起始列之后的连贯列数
ElseIf t = 0 Then
If js > 0 Then js = 0
Exit For '若不是连贯的列，则退出此循环，查找下一单元格
End If
Next c
If js = a - 1 Then '共同值出现在参数列数a的每一列中
cl = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
n = n + 1 '累加序号
For c = 1 To a
For rd = 1 To rz
If .Cells(rd, c) = .Cells(r, 1) And _
.Cells(rd, c).Interior.Color = 16777215 Then '值匹配且未染色
g = g + 1 '统计标注了几个
.Cells(rd, c).Interior.Color = cl '颜色值
j = j + 1 '同一共同值出现的次数
ReDim Preserve sz(1 To 10000, 1 To n)
sz(1, n) = n '比对序号
sz(2, n) = .Cells(r, 1).Value '共同值
sz(j + 2, n) = .Cells(rd, c).AddressLocal(0, 0) '共同值地址
End If
Next rd
Next c: js = 0: t = 0: j = 0 '标记完一个共同值后恢复初始值
End If
End If
Next r
End With
If g > 0 Then
With ActiveWorkbook
Set NB = .Sheets.Add(after:=.Sheets(.Sheets.Count))
With NB
.Name = Format(Now, "yyyymmddhmmss") & "比对结果"
.Range("A1") = .Name: .Range("A2") = "比对序号":
.Range("B2") = "共同值": .Range("C2") = "共同值对应的单元格地址"
.Range("A3").Resize(2, UBound(sz)) = WorksheetFunction.Transpose(sz)
.Range("A1:" & [A1].Offset(0, [A1].CurrentRegion.Columns.Count - 1).Address).Merge
.Range("C2:" & [A2].Offset(0, [A1].CurrentRegion.Columns.Count - 1).Address).Merge
.UsedRange.Borders.LineStyle = xlContinuous
.UsedRange.HorizontalAlignment = xlCenter
.Rows("1:2").RowHeight = 30: .Rows("1:2").Font.Bold = True
With .Tab
.Color = RGB(0, 0, 255)
End With
End With
Set NB = Nothing
End With
End If
en: Set qs = Nothing: Set q = Nothing: Erase sz '释放
End With
MsgBox "程序从" & a & "个连贯的列中标记出了它们之间的共同值，共" _
& g & "个单元格", IIf(g = 0, 16, 64), "提示：" & Err.Description
End Sub

楼上的代码，关于数组sz的结果有误，颜色标记暂无误。。。

'此版纠正了楼上代码混乱的数组数据写入逻辑，并再度优化代码

Sub 标记多个连贯列中的共同值()
Dim Na As String, qs As Range, q As Range, r As Long, c As Integer, _
rz As Long, cz As Integer, js As Integer, _
rd As Integer, a As Integer, g As Integer, _
t As Integer, cl As Double, n As Long, j As Integer, _
sz() As String, NB As Worksheet
On Error GoTo en
With ActiveWorkbook
For Each NB In .Worksheets
If InStr(1, NB.Name, "比对结果") > 0 Then
Application.DisplayAlerts = False
NB.Delete '删除比对结果表
Application.DisplayAlerts = True
End If
Next NB
End With
Na = ActiveSheet.Name '改成待比对的源数据表格名称
Set qs = Application.InputBox( _
"请选中数据区域左上角所在的单元格，然后点击确定", "起始参数设置：", Type:=8)
If qs = False Or qs.Cells.Count > 1 Then GoTo en
Application.ScreenUpdating = False
With Worksheets(Na)
Set q = .Range(qs.Address).CurrentRegion
.Select
'返回一个 Range 对象，该对象表示当前区域。当前区域是以空行与空列的组合为边界的区域。只读
With q
.Select
rz = .Rows.Count '总行数
cz = .Columns.Count '总列数
a = Application.InputBox( _
"你要从几个连贯的列中标记出它们的共同值？输入列数：", _
"提示：数据区域为" & .AddressLocal(0, 0), cz, , , , , 1)
If a = False Or a <= 0 Or a > cz Then GoTo en '不符合列的参数条件就结束
.Interior.Pattern = xlNone '清除填充的颜色
For r = 1 To rz
If Trim(.Cells(r, 1)) <> "" Then '只找非空值
For c = 2 To a
t = WorksheetFunction.CountIf(.Columns(c), .Cells(r, 1))
If t > 0 Then
js = js + 1 '统计起始列之后的连贯列数
ElseIf t = 0 Then
If js > 0 Then js = 0
Exit For '若不是连贯的列，则退出此循环，查找下一单元格
End If
Next c
If js = a - 1 Then '共同值出现在参数列数a的每一列中
cl = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
For c = 1 To a
For rd = 1 To rz
If .Cells(rd, c) = .Cells(r, 1) And _
.Cells(rd, c).Interior.Color = 16777215 Then '值匹配且未染色
g = g + 1 '统计标注了几个
.Cells(rd, c).Interior.Color = cl '颜色值
j = j + 1 '同一共同值出现的次数
If j = 1 Then n = n + 1 '开始找同一个共同值时
ReDim Preserve sz(1 To 10000, 1 To n)
sz(1, n) = n '比对序号
sz(2, n) = .Cells(r, 1).Value '共同值
sz(3, n) = j '出现次数
sz(j + 3, n) = .Cells(rd, c).AddressLocal(0, 0) '共同值地址
End If
Next rd
Next c: js = 0: t = 0: j = 0 '标记完一个共同值后恢复初始值
End If
End If
Next r
End With
If g > 0 Then
With ActiveWorkbook
Set NB = .Sheets.Add(after:=.Sheets(.Sheets.Count))
With NB
.Name = Format(Now, "yyyymmddhmmss") & "比对结果"
.Range("A1") = .Name & ",源数据表：" & Na: .Range("A2") = "比对序号":
.Range("B2") = "共同值": .Range("C2") = "出现次数"
.Range("D2") = "共同值对应的单元格地址"
.Range("A3").Resize(n, UBound(sz)) = WorksheetFunction.Transpose(sz)
.Range("A1:" & [A1].Offset(0, [A1].CurrentRegion.Columns.Count - 1).Address).Merge
.Range("D2:" & [A2].Offset(0, [A1].CurrentRegion.Columns.Count - 1).Address).Merge
.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.Range("A1").CurrentRegion.HorizontalAlignment = xlCenter
.Rows("1:2").RowHeight = 30: .Rows("1:2").Font.Bold = True
.UsedRange.Columns.AutoFit
With .Tab
.Color = RGB(0, 0, 255)
End With
End With
Set NB = Nothing
End With
End If
en: Set qs = Nothing: Set q = Nothing: Erase sz '释放
Application.ScreenUpdating = True
End With
MsgBox "程序从" & a & "个连贯的列中标记出了它们之间的共同值，共" _
& g & "个单元格", IIf(g = 0, 16, 64), "提示：" & Err.Description
End Sub

选中某单元格，然后把和选中单元格内容相同的所有单元格加上颜色，这样不更直观吗？

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rg As Range, St$, SumRg As Range
Myr = ActiveSheet.UsedRange.Rows.Count
Cells.Interior.Pattern = 0 '去除背景色
If Target.Address Like "*[:,]*" Then Exit Sub '选中单元格超过1个，退出
If Target.Value = "" Then Exit Sub '选中的单元格为空时，退出
Set Rg = Range("a1:d" & Myr).Find(Target.Value, , , xlWhole)
If Not Rg Is Nothing Then
St = Rg.Address
Set SumRg = Rg
Do
Set Rg = Range("a1:d" & Myr).Find(Target.Value, Rg, , xlWhole)
Set SumRg = Union(SumRg, Rg)
Loop While Rg.Address <> St
SumRg.Select '选中相同内容单元格
Selection.Interior.ColorIndex = 27 '改变背景色
End If
End Sub