设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 如何对满足特定条件的单元格进行颜色标识（要求见附件）
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 5721|回复: 7

[已解决]如何对满足特定条件的单元格进行颜色标识（要求见附件）

[复制链接]
发表于 2012-9-6 15:03 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 suye1010 于 2012-9-7 22:21 编辑

如题，请各位帮助解决底色填充问题。
最佳答案
月排行榜 / 总排行榜
suye1010
2012-9-7 16:05
本帖最后由 suye1010 于 2012-9-9 12:00 编辑
  1. Option Explicit
  2. Private Sub ColorMark_Click()
  3. Dim i, j, k, l, dL, dS, arr(1 To 6), arr1(1 To 6), temp, temp1, m, n, p
  4. Set dL = CreateObject("scripting.dictionary")
  5. Set dS = CreateObject("scripting.dictionary")
  6. Cells.Interior.ColorIndex = 0
  7. For i = 8 To Application.InputBox("请选择待处理数据区域，从第一行开始到待分析数据末尾", "数据源", , , , , , 8).Rows.Count
  8.     For k = i - 1 To 1 Step -1
  9.         m = 0
  10.         For l = 1 To 6
  11.           arr(l) = Application.WorksheetFunction.Count(Range(Cells(k, l), Cells(i - 1, l)))
  12.           arr1(l) = 11 + l
  13.         Next l
  14.         For p = 1 To 6 '在这里设置你要停止统计开始分组的条件
  15.             If arr(p) >= 2 And arr(p) > Application.WorksheetFunction.Small(arr, 3) Then m = m + 1
  16.         Next p
  17.         If m = 3 Then
  18.             For n = 1 To 5 '这里对6个数据进行了排序，在本题目中，可以把n取到3以减少运算
  19.                 For j = 6 To n + 1 Step -1
  20.                     If arr(j) > arr(j - 1) Then
  21.                         temp = arr(j)
  22.                         temp1 = arr1(j)
  23.                         arr(j) = arr(j - 1)
  24.                         arr1(j) = arr1(j - 1)
  25.                         arr(j - 1) = temp
  26.                         arr1(j - 1) = temp1
  27.                     End If
  28.                 Next j
  29.             Next n
  30.             Exit For
  31.         End If
  32.     Next k
  33.     For j = 1 To 6
  34.         If j < 4 Then
  35.             dL(arr1(j)) = arr1(j)
  36.         Else
  37.             dS(arr1(j)) = arr1(j)
  38.         End If
  39.     Next j
  40.     For j = 1 To 6
  41.         If dL.Exists(Cells(i, j).Value) Then Cells(i, j).Interior.ColorIndex = 3
  42.         If dS.Exists(Cells(i, j).Value) Then Cells(i, j).Interior.ColorIndex = 5
  43.     Next j
  44.     dL.RemoveAll: dS.RemoveAll
  45.     Erase arr: Erase arr1
  46. Next i
  47. End Sub
复制代码

用vba进行统计.zip

13.88 KB, 下载次数: 40
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2012-9-7 16:05 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 suye1010 于 2012-9-9 12:00 编辑
  1. Option Explicit
  2. Private Sub ColorMark_Click()
  3. Dim i, j, k, l, dL, dS, arr(1 To 6), arr1(1 To 6), temp, temp1, m, n, p
  4. Set dL = CreateObject("scripting.dictionary")
  5. Set dS = CreateObject("scripting.dictionary")
  6. Cells.Interior.ColorIndex = 0
  7. For i = 8 To Application.InputBox("请选择待处理数据区域，从第一行开始到待分析数据末尾", "数据源", , , , , , 8).Rows.Count
  8.     For k = i - 1 To 1 Step -1
  9.         m = 0
  10.         For l = 1 To 6
  11.           arr(l) = Application.WorksheetFunction.Count(Range(Cells(k, l), Cells(i - 1, l)))
  12.           arr1(l) = 11 + l
  13.         Next l
  14.         For p = 1 To 6 '在这里设置你要停止统计开始分组的条件
  15.             If arr(p) >= 2 And arr(p) > Application.WorksheetFunction.Small(arr, 3) Then m = m + 1
  16.         Next p
  17.         If m = 3 Then
  18.             For n = 1 To 5 '这里对6个数据进行了排序，在本题目中，可以把n取到3以减少运算
  19.                 For j = 6 To n + 1 Step -1
  20.                     If arr(j) > arr(j - 1) Then
  21.                         temp = arr(j)
  22.                         temp1 = arr1(j)
  23.                         arr(j) = arr(j - 1)
  24.                         arr1(j) = arr1(j - 1)
  25.                         arr(j - 1) = temp
  26.                         arr1(j - 1) = temp1
  27.                     End If
  28.                 Next j
  29.             Next n
  30.             Exit For
  31.         End If
  32.     Next k
  33.     For j = 1 To 6
  34.         If j < 4 Then
  35.             dL(arr1(j)) = arr1(j)
  36.         Else
  37.             dS(arr1(j)) = arr1(j)
  38.         End If
  39.     Next j
  40.     For j = 1 To 6
  41.         If dL.Exists(Cells(i, j).Value) Then Cells(i, j).Interior.ColorIndex = 3
  42.         If dS.Exists(Cells(i, j).Value) Then Cells(i, j).Interior.ColorIndex = 5
  43.     Next j
  44.     dL.RemoveAll: dS.RemoveAll
  45.     Erase arr: Erase arr1
  46. Next i
  47. End Sub
复制代码

用vba进行统计.zip

21.07 KB, 下载次数: 19

售价: 1 个金币  [记录]

回复

使用道具 举报

 楼主| 发表于 2012-9-7 19:22 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
suye1010 发表于 2012-9-7 16:05

谢谢你在留言中给我的提醒，并对你的不辞辛苦的帮助表示由衷感谢，我对你给我的板块进行验证，有个小小的地方需要改变一下：根据必须分成3列为一组，16行往上分到10行为止，才能分成较多的一组是13,14,17，所以17行出现的17应为红色；从27行往上分，应到17行为止，才能分成较多的一组13,16,17，所以28行出现的12应为蓝色，16应为红色。请你修改一下好吗。
回复

使用道具 举报

发表于 2012-9-7 21:12 | 显示全部楼层
喜欢电子表格 发表于 2012-9-7 19:22
谢谢你在留言中给我的提醒，并对你的不辞辛苦的帮助表示由衷感谢，我对你给我的板块进行验证，有个小小的 ...

你的条件究竟是如何定义的？完全不懂你的意思了……
到底是3列中数字出现2次以上还是3次开始分组？
如若不是，那种情况下以出现3次为准，哪些情况下以出现2次为准？ 譬如从7到25行以出现2次为准分组，从26行开始以出现3次为准分组……

请明确你的分组规则。
回复

使用道具 举报

 楼主| 发表于 2012-9-8 12:58 | 显示全部楼层
suye1010 发表于 2012-9-7 21:12
你的条件究竟是如何定义的？完全不懂你的意思了……
到底是3列中数字出现2次以上还是3次开始分组？
如若 ...

用vba.rar (13.86 KB, 下载次数: 23)
回复

使用道具 举报

 楼主| 发表于 2012-9-9 07:15 | 显示全部楼层
suye1010 发表于 2012-9-7 16:05

非常感谢-----------------------------
回复

使用道具 举报

 楼主| 发表于 2012-9-9 22:19 | 显示全部楼层
本帖最后由 喜欢电子表格 于 2012-9-9 22:32 编辑
suye1010 发表于 2012-9-7 16:05


真是不好意思，还要麻烦你：在abcdef6列中每列的数字如果换成其他自然数，这个做好的vba就不能用，能不能把相关内容改变一下，改成abcdef列内的自然数，适应于1位到2位的一切自然数，谢谢你。（同列的自然数是相同的,,不同列的自然数各不相同）
回复

使用道具 举报

发表于 2012-9-10 19:05 | 显示全部楼层
喜欢电子表格 发表于 2012-9-9 22:19
真是不好意思，还要麻烦你：在abcdef6列中每列的数字如果换成其他自然数，这个做好的vba就不能用，能不 ...
  1. Option Explicit
  2. Private Sub ColorMark_Click()
  3. Dim i, j, k, l, dL, dS, arr(1 To 6), arr1(1 To 6), temp, temp1, m, n, p
  4. Set dL = CreateObject("scripting.dictionary")
  5. Set dS = CreateObject("scripting.dictionary")
  6. Cells.Interior.ColorIndex = 0
  7. For i = 8 To Application.InputBox("请选择待处理数据区域，从第一行开始到待分析数据末尾", "数据源", , , , , , 8).Rows.Count
  8.     For k = i - 1 To 1 Step -1
  9.         m = 0
  10.         For l = 1 To 6
  11.           arr(l) = Application.WorksheetFunction.Count(Range(Cells(k, l), Cells(i - 1, l)))
  12.           arr1(l) = Cells(65536, l).End(xlUp) '这里是用来提取每一列中的数字的
  13.         Next l
  14.         For p = 1 To 6 '在这里设置你要停止统计开始分组的条件
  15.             If arr(p) >= 2 And arr(p) > Application.WorksheetFunction.Small(arr, 3) Then m = m + 1
  16.         Next p
  17.         If m = 3 Then
  18.             For n = 1 To 3
  19.                 For j = 6 To n + 1 Step -1
  20.                     If arr(j) > arr(j - 1) Then
  21.                         temp = arr(j)
  22.                         temp1 = arr1(j)
  23.                         arr(j) = arr(j - 1)
  24.                         arr1(j) = arr1(j - 1)
  25.                         arr(j - 1) = temp
  26.                         arr1(j - 1) = temp1
  27.                     End If
  28.                 Next j
  29.             Next n
  30.             Exit For
  31.         End If
  32.     Next k
  33.     For j = 1 To 6
  34.         If j < 4 Then
  35.             dL(arr1(j)) = arr1(j)
  36.         Else
  37.             dS(arr1(j)) = arr1(j)
  38.         End If
  39.     Next j
  40.     For j = 1 To 6
  41.         If dL.Exists(Cells(i, j).Value) Then Cells(i, j).Interior.ColorIndex = 3
  42.         If dS.Exists(Cells(i, j).Value) Then Cells(i, j).Interior.ColorIndex = 5
  43.     Next j
  44.     dL.RemoveAll: dS.RemoveAll
  45.     Erase arr: Erase arr1
  46. Next i
  47. End Sub
复制代码
用vba进行统计.zip (21.05 KB, 下载次数: 2, 售价: 1 个金币)
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-5-29 18:04 , Processed in 0.544612 second(s), 7 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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