Excel·VBA单元格区域数据对比差异标记颜色 |
您所在的位置：网站首页 › 两个单元格文字相同标记 › Excel·VBA单元格区域数据对比差异标记颜色 |
Excel·VBA单元格区域数据对比差异标记颜色
|
目录
差异标色举例
相同标色举例
之前的一篇博客《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
与上面的 差异标色 不同，对一行单元格所有数据相同的标记颜色，代码差异很小 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
|
对比差异并标记黄色 
【本文地址】
今日新闻 |
推荐新闻 |