之前的一篇博客《Excel·VBA单元格重复值标记颜色》,是对重复的整行标记颜色
而本文是按行对比2个单元格区域的数据,并对有差异的区域(一个单元格区域有的,而另一个单元格区域没有的)标记颜色,且只要存在任意1个字符不同的,则标记颜色
差异标色
代码写为自定义函数使用更为方便,并使用 Union 方法在每个单元格区域判断结束后统一标色
Function 单元格区域数据对比标色_不同(ByVal rng1 As Range, ByVal rng2 As Range)
'2个单元格区域数据按行对比,1个区域中有另1个区域中无则标色,每行中任意1个字符不同则标色
Dim dict1 As Object, dict2 As Object, delimiter$, color_index&, i&, j&, temp$, k, color_rng As Range
Set dict1 = CreateObject("scripting.dictionary"): delimiter = Chr(28) '分隔符
Set dict2 = CreateObject("scripting.dictionary"): color_index = 6 '标记黄色
For i = 1 To rng1.Rows.Count 'rng1写入字典
temp = ""
For j = 1 To rng1.Columns.Count
temp = temp & delimiter & rng1.Cells(i, j).Value
Next
If Not dict1.Exists(temp) Then
Set dict1(temp) = rng1.Rows(i)
Else
Set dict1(temp) = Union(dict1(temp), rng1.Rows(i))
End If
Next
For i = 1 To rng2.Rows.Count 'rng2写入字典
temp = ""
For j = 1 To rng2.Columns.Count
temp = temp & delimiter & rng2.Cells(i, j).Value
Next
If Not dict2.Exists(temp) Then
Set dict2(temp) = rng2.Rows(i)
Else
Set dict2(temp) = Union(dict2(temp), rng2.Rows(i))
End If
Next
For Each k In dict1.keys '遍历dict1,判断所有键在dict2中是否存在,不存在则写入标色区域color_rng
If Not dict2.Exists(k) Then
If color_rng Is Nothing Then
Set color_rng = dict1(k)
Else
Set color_rng = Union(color_rng, dict1(k))
End If
End If
Next
'Union无法跨工作表使用,故先对color_rng标色1次
If Not color_rng Is Nothing Then color_rng.Interior.ColorIndex = color_index: Set color_rng = Nothing
For Each k In dict2.keys '遍历dict2,判断所有键在dict1中是否存在
If Not dict1.Exists(k) Then
If color_rng Is Nothing Then
Set color_rng = dict2(k)
Else
Set color_rng = Union(color_rng, dict2(k))
End If
End If
Next
If Not color_rng Is Nothing Then color_rng.Interior.ColorIndex = color_index: Set color_rng = Nothing
Debug.Print "单元格区域数据对比标色_不同,完成"
End Function
举例
Sub 测试()
Dim rng1 As Range, rng2 As Range
Set rng1 = Worksheets("表1").[a1].CurrentRegion
Set rng2 = Worksheets("表2").[a1].CurrentRegion
a = 单元格区域数据对比标色_不同(rng1, rng2)
End Sub
对比差异并标记黄色
相同标色
与上面的 差异标色 不同,对一行单元格所有数据相同的标记颜色,代码差异很小文章来源:https://www.toymoban.com/news/detail-723458.html
Function 单元格区域数据对比标色_相同(ByVal rng1 As Range, ByVal rng2 As Range)
'2个单元格区域数据按行对比,1个区域中有另1个区域中无则标色,每行中任意1个字符不同则标色,黄色6/27
Dim dict1 As Object, dict2 As Object, delimiter$, color_index&, i&, j&, temp$, k, color_rng As Range
Set dict1 = CreateObject("scripting.dictionary"): delimiter = Chr(28) '分隔符
Set dict2 = CreateObject("scripting.dictionary"): color_index = 6 '标记黄色
For i = 1 To rng1.Rows.Count 'rng1写入字典
temp = ""
For j = 1 To rng1.Columns.Count
temp = temp & delimiter & rng1.Cells(i, j).Value
Next
If Not dict1.Exists(temp) Then
Set dict1(temp) = rng1.Rows(i)
Else
Set dict1(temp) = Union(dict1(temp), rng1.Rows(i))
End If
Next
For i = 1 To rng2.Rows.Count 'rng2写入字典
temp = ""
For j = 1 To rng2.Columns.Count
temp = temp & delimiter & rng2.Cells(i, j).Value
Next
If Not dict2.Exists(temp) Then
Set dict2(temp) = rng2.Rows(i)
Else
Set dict2(temp) = Union(dict2(temp), rng2.Rows(i))
End If
Next
For Each k In dict1.keys '遍历dict1,判断所有键在dict2中是否存在,存在则写入标色区域color_rng
If dict2.Exists(k) Then
If color_rng Is Nothing Then
Set color_rng = dict1(k)
Else
Set color_rng = Union(color_rng, dict1(k))
End If
End If
Next
'Union无法跨工作表使用,故先对color_rng标色1次
If Not color_rng Is Nothing Then color_rng.Interior.ColorIndex = color_index: Set color_rng = Nothing
For Each k In dict2.keys '遍历dict2,判断所有键在dict1中是否存在
If dict1.Exists(k) Then
If color_rng Is Nothing Then
Set color_rng = dict2(k)
Else
Set color_rng = Union(color_rng, dict2(k))
End If
End If
Next
If Not color_rng Is Nothing Then color_rng.Interior.ColorIndex = color_index: Set color_rng = Nothing
Debug.Print "单元格区域数据对比标色_相同,完成"
End Function
举例
Sub 测试()
Dim rng1 As Range, rng2 As Range
Set rng1 = Worksheets("表1").[a1].CurrentRegion
Set rng2 = Worksheets("表2").[a1].CurrentRegion
a = 单元格区域数据对比标色_相同(rng1, rng2)
End Sub
对比相同并标记黄色,结果与“差异标色”相反
文章来源地址https://www.toymoban.com/news/detail-723458.html
到了这里,关于Excel·VBA单元格区域数据对比差异标记颜色的文章就介绍完了。如果您还想了解更多内容,请在右上角搜索TOY模板网以前的文章或继续浏览下面的相关文章,希望大家以后多多支持TOY模板网!