|
发表于 2017-2-17 16:15
|
显示全部楼层
本楼为最佳答案
给你做了个二个以上任意多个区域的。
- Sub tt()
- Dim rg As Range
- Dim sRg(1 To 100) As Range '数组:每一块区域
- ActiveSheet.Cells.Interior.ColorIndex = 0
- Set rg = Application.InputBox("请选择区域,按CTRL多选", Type:=8) '选定多块区域
- rg.Interior.ColorIndex = 6
- rmin = rg.Rows.Count: cmin = rg.Columns.Count
- ad = rg.Address(0, 0)
- If InStr(ad, ",") = 0 Then MsgBox "请选择至少2块区域": Exit Sub
-
- xrr = Split(ad, ",") '每一块区域的地址
- For Each x In xrr
- n = n + 1
- Set sRg(n) = Range(x) '每一块区域
- If rmin > sRg(n).Rows.Count Then rmin = sRg(n).Rows.Count '所有区域的最小行
- If cmin > sRg(n).Columns.Count Then cmin = sRg(n).Columns.Count '所有区域的最小列
- Next
-
- Set d = CreateObject("scripting.dictionary") '字典:记录相同位置中每一个区域的地址
- For i = 1 To n
- Set sRg(i) = sRg(i).Cells(1, 1).Resize(rmin, cmin)
- For k = 1 To sRg(i).Cells.Count
- d(k) = d(k) & "," & sRg(i).Cells(k).Address(0, 0)
- Next
- Next
-
- For Each i In d.keys
- xrr = Split(d(i), ",")
- xvalue = Range(xrr(1)).Value '判断每一个区域相同位置是否相同
- For k = 2 To UBound(xrr)
- If Range(xrr(k)).Value <> xvalue Then Exit For
- Next
- If k > UBound(xrr) Then Range(Mid(d(i), 2)).Interior.ColorIndex = 3 '不相同,标色。
- Next
- End Sub
复制代码 |
评分
-
查看全部评分
|