vba吧 关注：17,036贴子：66,524
北海不北
大神，怎么把多列文本都出现的重复值标记不同颜色
Sub InterColor2()
Dim myrange As Range, n As Range
h = 3
Do While h < 31
For l = 3 To 20
Set myrange = Cells(l, h)
For Each n In Range("C3:T30")
If n.Value = Cells(l, h).Value Then
Set myrange = Union(myrange, n)
myrange.Interior.Color = RGB((Int(256 * Rnd())), (Int(256 * Rnd())), (Int(256 * Rnd())))
End If
Next
Next
h = h + 1
Loop
End Sub
Dim myrange As Range, n As Range
h = 3
Do While h < 31
For l = 3 To 20
Set myrange = Cells(l, h)
For Each n In Range("C3:T30")
If n.Value = Cells(l, h).Value Then
Set myrange = Union(myrange, n)
myrange.Interior.Color = RGB((Int(256 * Rnd())), (Int(256 * Rnd())), (Int(256 * Rnd())))
End If
Next
Next
h = h + 1
Loop
End Sub
Sub InterColor3()
Dim rStart As Integer
Dim rEnd As Integer
Dim cStart As Integer
Dim cEnd As Integer
Dim nColumns As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
rStart = 3 '开始行
rEnd = 30 '结束行
cStart = 2 '开始列
cEnd = 4 '结束列
nColumns = cEnd - cStart + 1 '数据列数
For i = rStart To rEnd
If Application.WorksheetFunction.CountIf(Range(Cells(rStart, cStart), Cells(rEnd, cEnd)), Cells(i, cStart)) = nColumns Then
Cells(i, cStart).Interior.Color = RGB((Int(256 * Rnd())), (Int(256 * Rnd())), (Int(256 * Rnd())))
For j = rStart To rEnd
For k = cStart + 1 To cEnd
If Cells(j, k) = Cells(i, cStart) Then
Cells(j, k).Interior.Color = Cells(i, cStart).Interior.Color
Exit For
End If
Next k
Next j
End If
Next i
End Sub
Dim rStart As Integer
Dim rEnd As Integer
Dim cStart As Integer
Dim cEnd As Integer
Dim nColumns As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
rStart = 3 '开始行
rEnd = 30 '结束行
cStart = 2 '开始列
cEnd = 4 '结束列
nColumns = cEnd - cStart + 1 '数据列数
For i = rStart To rEnd
If Application.WorksheetFunction.CountIf(Range(Cells(rStart, cStart), Cells(rEnd, cEnd)), Cells(i, cStart)) = nColumns Then
Cells(i, cStart).Interior.Color = RGB((Int(256 * Rnd())), (Int(256 * Rnd())), (Int(256 * Rnd())))
For j = rStart To rEnd
For k = cStart + 1 To cEnd
If Cells(j, k) = Cells(i, cStart) Then
Cells(j, k).Interior.Color = Cells(i, cStart).Interior.Color
Exit For
End If
Next k
Next j
End If
Next i
End Sub
Sub 标记多个连贯列中的共同值()
Dim 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
On Error GoTo en
' With Sheet1'此句已注释掉
With ActiveSheet
Set qs = Application.InputBox( _
"请选中数据区域左上角所在的单元格，然后点击确定", "起始参数设置：", Type:=8)
If qs = False Or qs.Cells.Count > 1 Then GoTo en
Set q = .Range(qs.Address).CurrentRegion
'返回一个 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))
g = g + 1 '统计标注了几个
.Cells(r, 1).Interior.Color = cl '颜色值
For rd = 1 To rz
For c = 2 To a
If .Cells(rd, c) = .Cells(r, 1) Then
g = g + 1 '统计标注了几个
.Cells(rd, c).Interior.Color = cl '颜色值
End If
Next c
Next rd: js = 0: t = 0 '标记完一个共同值后恢复初始值
End If
End If
Next r
End With
en: Set qs = Nothing: Set q = Nothing '释放
End With
MsgBox "程序从至少" & a & "列中标记出了它们之间的共同值，共" _
& g & "个单元格", IIf(g = 0, 16, 64), "提示：" & Err.Description
End Sub
