查找单元格并上色的几种方法浅析

楼主 xmyjk	问题:在表中查找所需的内容的单元格，并上色，如下图。问题.rar 解答如下，见后分解。
2楼 xmyjk	解答:对于这个问题，大家肯定会想到，很简单的，就是把区域所有的单元格找一遍，记录找到的，上色不就完了。这就是第一种方法：zaezhong的历遍单元格法： Sub test() Dim rng As Range, Adds$, i% For Each rng In [a1].CurrentRegion '历遍查找区域的所有单元格 If rng = "我要的" Then Adds = Adds & rng.Address(0, 0) & "," '如果找到，用ADDS变量记录其地址，每个记录用“,”进行间隔 Next With Range(Left$(Adds, Len(Adds) - 1)) '用RANGE对象控制所找到的单元格 For i = 1 To .Areas.Count '历遍所找到的单元格 .Areas(i).Interior.ColorIndex = 46 ' 对每个单元格上色 Next End With End Sub 1.历遍单元格法.rar 这种方法需要历遍所有的单元格对象，速度较慢（由于研究要求用RANGE对象控制，zaezhong老师多做了个循环，不然在IF那里历遍时就可以上色了，还会更快的）那有没快的方法呢，有人肯定会说，用EXCEL自身的查找功能录个宏不就行了，是的，这也是一个很好的办法，见下楼：
3楼 xmyjk	这就是第二种方法：zzmxy的FIND法：Sub zz() FindStr$ = Application.InputBox("请输入要查找的内容：", , "我要的") '输入要查找的值 Set Rng = ActiveSheet.UsedRange.Find(FindStr, LookIn:=xlValues) '对表进行查找 If Rng Is Nothing Then Exit Sub '如找不到，即退出程序 Set Arr = Rng '用ARR变量取得找到的第一个单元格 StartAdd = Rng.Address '用STARTADD变量取得找到的第一个单元格的地址 Do '开始循环查找后续的单元格 Set Arr = Union(Arr, Rng) '用UNION函数控制所有找到的单元格，UNION的做法就类似按住键盘CTRL键然后点击所需单元格的控制方式 Set Rng = ActiveSheet.UsedRange.FindNext(Rng) '查找下一个符合条件的单元格 Loop While StartAdd <> Rng.Address '如查找到的单元格的地址与第一个单元格的地址相同，就退出循环 Arr.Interior.ColorIndex = 46 '对所有找到的单元格上色 End Sub 2.FIND法.rar 这种方法的效率明显加快了很多，因为FIND方法能显著的减少循环次数，加快了效率。这种方法在数据源少的时候，效率非常高。缺点就是在查找的过程时，还是需要对单元格对象进行操作，这样的操作还是比较费时的，有什么解决办法呢？有的，把单元格的数值全部倒入数值再进行查找不就完了。见楼下：
4楼 xmyjk	第三种办法：xmyjk的数组法 Sub text1() Dim arr, i As Long, j As Long, brr() As String, m As Long, res As String, t As Single Application.DisplayAlerts = False '关闭屏幕显示 t = Timer m = 0 '计数器归零 arr = Range(Cells(1, 1), Cells([a65536].End(3).Row, [iv1].End(xlToLeft).Column)).Value '将区域导入数组ARR For i = LBound(arr, 1) To UBound(arr, 1) '历遍数组 For j = LBound(arr, 2) To UBound(arr, 2) '查找所需数据 If arr(i, j) = "我要的" Then '如果找到 m = m + 1 '计数器加1 ReDim Preserve brr(1 To m) '增加结果数组的维度 brr(m) = Chr(j + 64) & i '将找到的地址进行转换成类似A1格式并储存进结果数组 End If Next Next res = Join(brr, ",") '将结果数组合并成字符串，并以","为间隔 Range(res).Interior.ColorIndex = 46 '使用RANGE对象控制找到的单元格，并进行上色 Application.DisplayAlerts = True '开启屏幕显示 MsgBox Timer - t & "秒" End Sub 3.数组法.rar 但是，数值法还是没法有效的减少循环次数，因此如果在少数据量时候，FIND法略快。但是如果随着数据量的增加，数值法由于不需操作对象进行查找，仅仅在内存中查找数值，速度明显的加快了。大家可以试看看如下附件，3000多个数据，同样使用UNION方式控制单元格，用FIND和数组查找的效率区别，在我的老机子上，FIND法大概要14秒，数组法大概10秒。 4.对比FIND与数组.rar 还要10几秒钟啊，估计还是有些网友会说，还有没更快的法子啊，呵呵有的，就如同查找空行最快的方法是AUTOFILTER一样，EXCEL总是给我们惊喜，条件格式法
5楼 xmyjk	第四方法：xmyjk的条件格式法：(前提，必须要03版以上的EXCEL,03版只支持三个条件格式，据说10版支持60几个条件格式，如果需要上色类别不多，可以使用这个方法)Sub 宏1() Dim t As Single Application.DisplayAlerts = False '关闭屏幕显示 t = Timer Cells.FormatConditions.Delete '清楚表中原来的条件格式 With Cells(1, 1).CurrentRegion.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""我要的""") '把所要查找的值做成条件格式 .Interior.ColorIndex = 46 '条件格式即为上色 End With Application.DisplayAlerts = True '开启屏幕显示 MsgBox Timer - t & "秒" End Sub 5.条件格式法解答.rar 条件格式法的效率显著较高，3000多个所需查找数值并上色，仅仅花了不到0.15秒。且代码简单，录个宏改改就行了。缺点就是，类别不能多，不然要增加很多条件格式，且对条件格式数量也是有限制的。
6楼 xmyjk	最后，问题圆满解决了，附送研究整理完的上色程序供大家参考，再附送一个数组查找的衍生方法：数组+字典的上色法（不需两个数组，但速度比双数组慢，调用外部对象毕竟满，好处就是不用反复的扩充结果数组的维度简化程序）。以上供大家学习参考，非科班出身，欢迎指点拍砖。 7.研究整理后程序.rar 6.1数组+1字典法.rar
7楼 xmyjk	楼上指教的是，确实RANGE法有这个缺点，因此四楼的附件，我用UNION的方法做，没有用RANGE的方法做去做用RANGE做的方法的初衷，是因为采集的那个求助贴的要求，因此，我们几个人都是按照RANGE来回答的。四楼UNION做的代码如下 Sub text1() Dim arr, i As Long, j As Long, m As Long, t As Single, rng As Range Application.DisplayAlerts = False t = Timer m = 0 arr = Range(Cells(1, 1), Cells([a65536].End(3).Row, [iv1].End(xlToLeft).Column)).Value For i = LBound(arr, 1) To UBound(arr, 1) For j = LBound(arr, 2) To UBound(arr, 2) If arr(i, j) = "我要的" Then m = m + 1 If m = 1 Then Set rng = Cells(i, j) Else Set rng = Union(rng, Cells(i, j)) End If End If Next Next rng.Interior.ColorIndex = 46 Application.DisplayAlerts = True MsgBox Timer - t & "秒" End Sub
8楼研究研究	字符串长度在255内我已经解决了啊第2个问题26个字母是个问题。但当时对方没有提出超过26列的要求。所以暂时没有考虑在其中
9楼 xmyjk	楼上误解微软的说明文件了。 UNION(RANGE1,RANGE2,...RANGE30)，UNION指的是一次仅仅可操作30个range 而我们用的办法是，A单元格和B用UNION得到的区域后再与C单元格UNION，不会突破UNION同时操作30个区域的限制。你看看以下代码，测试下附件即知，我们利用此方法用UNION选择了1697个单元格都没有报错。 Option Explicit Sub zz() Dim t As Single, rng As Range, arr As Range, StartAdd As String, findstr As String, n As Long Application.DisplayAlerts = False t = Timer findstr = "我要的" Set rng = ActiveSheet.UsedRange.Find(findstr, LookIn:=xlValues) If rng Is Nothing Then Exit Sub Set arr = rng StartAdd = rng.Address n = 1 Do Set arr = Union(arr, rng) n = n + 1 Set rng = ActiveSheet.UsedRange.FindNext(rng) Loop While StartAdd <> rng.Address arr.Interior.ColorIndex = 46 Application.DisplayAlerts = True MsgBox Timer - t & "秒" & "用UNION共计选定单元格" & n & "个" End Sub 测试.rar
10楼 wqfzqgk	今天看的好无聊啊，也没事可做，
11楼 bishunbiao	水平有限，只能看懂一部分。看来只能先留下脚印啦。
12楼 luckydog	学习一下
13楼 wangpingqing	马呀，一个上色都这么猛～～
14楼冰心8549	谢谢分享，学习学习
15楼老糊涂	收藏学习了
16楼 keven	赞一个！