Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2239|回复: 9

[已解决]相同数字则填充红色

[复制链接]
发表于 2017-2-17 11:12 | 显示全部楼层 |阅读模式
本帖最后由 mate33 于 2017-2-17 19:18 编辑

相同数字则填充红色
最佳答案
2017-2-17 16:15
给你做了个二个以上任意多个区域的。
  1. Sub tt()
  2.     Dim rg As Range
  3.     Dim sRg(1 To 100) As Range   '数组:每一块区域
  4.     ActiveSheet.Cells.Interior.ColorIndex = 0
  5.     Set rg = Application.InputBox("请选择区域,按CTRL多选", Type:=8)   '选定多块区域
  6.     rg.Interior.ColorIndex = 6
  7.     rmin = rg.Rows.Count: cmin = rg.Columns.Count
  8.     ad = rg.Address(0, 0)
  9.     If InStr(ad, ",") = 0 Then MsgBox "请选择至少2块区域": Exit Sub
  10.    
  11.     xrr = Split(ad, ",")   '每一块区域的地址
  12.     For Each x In xrr
  13.         n = n + 1
  14.         Set sRg(n) = Range(x)     '每一块区域
  15.         If rmin > sRg(n).Rows.Count Then rmin = sRg(n).Rows.Count       '所有区域的最小行
  16.         If cmin > sRg(n).Columns.Count Then cmin = sRg(n).Columns.Count       '所有区域的最小列
  17.     Next
  18.    
  19.     Set d = CreateObject("scripting.dictionary")    '字典:记录相同位置中每一个区域的地址
  20.     For i = 1 To n
  21.         Set sRg(i) = sRg(i).Cells(1, 1).Resize(rmin, cmin)
  22.         For k = 1 To sRg(i).Cells.Count
  23.             d(k) = d(k) & "," & sRg(i).Cells(k).Address(0, 0)
  24.         Next
  25.     Next
  26.    
  27.     For Each i In d.keys
  28.         xrr = Split(d(i), ",")
  29.         xvalue = Range(xrr(1)).Value      '判断每一个区域相同位置是否相同
  30.         For k = 2 To UBound(xrr)
  31.             If Range(xrr(k)).Value <> xvalue Then Exit For
  32.         Next
  33.         If k > UBound(xrr) Then Range(Mid(d(i), 2)).Interior.ColorIndex = 3     '不相同,标色。
  34.     Next
  35. End Sub
复制代码

相同数字填充红色.rar

8.37 KB, 下载次数: 17

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2017-2-17 13:23 | 显示全部楼层
有没有老师会解答的,如果没有描述清楚可以补充。
回复

使用道具 举报

发表于 2017-2-17 14:21 | 显示全部楼层
  1. Sub tt()
  2.     Dim rg1 As Range, rg2 As Range
  3.     ActiveSheet.Cells.Interior.ColorIndex = 0
  4.     Set rg1 = Application.InputBox("请选择区域1", Type:=8)
  5.     rg1.Interior.ColorIndex = 6
  6.     Set rg2 = Application.InputBox("请选择区域2", Type:=8)
  7.     rg2.Interior.ColorIndex = 6
  8.    
  9.     rmin = Application.Min(rg1.Rows.Count, rg2.Rows.Count)
  10.     cmin = Application.Min(rg1.Columns.Count, rg2.Columns.Count)
  11.     Set rg1 = rg1.Cells(1, 1).Resize(rmin, cmin)
  12.     Set rg2 = rg2.Cells(1, 1).Resize(rmin, cmin)
  13.     For i = 1 To rg1.Cells.Count
  14.         If rg1.Cells(i) = rg2.Cells(i) Then
  15.             rg1.Cells(i).Interior.ColorIndex = 3
  16.             rg2.Cells(i).Interior.ColorIndex = 3
  17.         End If
  18.     Next
  19. End Sub
复制代码

相同数字填充红色.rar

17.85 KB, 下载次数: 3

评分

参与人数 1 +6 收起 理由
laoau138 + 6 来学习

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2017-2-17 15:00 | 显示全部楼层

非常感谢老师的出手解答。就是如果同时选择三个区域或者以上的,代码如何修改。
回复

使用道具 举报

发表于 2017-2-17 15:24 | 显示全部楼层
rg3  rg4 .....继续
回复

使用道具 举报

 楼主| 发表于 2017-2-17 15:31 | 显示全部楼层
grf1973 发表于 2017-2-17 15:24
rg3  rg4 .....继续

改了下没有改成功哦。麻烦老师可否做一个三区域的。
回复

使用道具 举报

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

相同数字填充红色.rar

20.71 KB, 下载次数: 8

评分

参与人数 1 +6 收起 理由
laoau138 + 6 来学习

查看全部评分

回复

使用道具 举报

发表于 2017-2-17 16:32 | 显示全部楼层
请看动画。
1.gif
回复

使用道具 举报

发表于 2017-2-17 19:15 | 显示全部楼层
grf1973 发表于 2017-2-17 16:15
给你做了个二个以上任意多个区域的。



VBA在在texbox1输入编码  然后查找如何做


http://www.excelpx.com/thread-427857-1-1.html

回复

使用道具 举报

发表于 2017-8-11 14:20 | 显示全部楼层
学习了
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 08:53 , Processed in 0.737400 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表