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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 满足条例的最大数填充红色。
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2924|回复: 5

[已解决]满足条例的最大数填充红色。

[复制链接]
left369
发表于 2014-5-31 14:26 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
满足条例的最大数填充红色。
最佳答案
月排行榜 / 总排行榜
fffox
2014-5-31 18:04
left369 发表于 2014-5-31 16:50
你好，老师。我没表述清楚哦。不好意思。再做了几个例子。老师看看。

再看一下：
  1. Option Explicit

  3. Sub test()
  4.     Dim arr_col, arr_row, brr, crr(), iMax%, iMin%
  5.     Dim i%, j%, RngMax As Range, RngMin As Range
  6.     With Sheets(1)
  7.         arr_row = .Range("a17:a26")
  8.         arr_col = .Range("b13", Cells(13, Cells(13, Columns.Count).End(1).Column))
  9.         brr = .Range("b17").Resize(UBound(arr_row), UBound(arr_col, 2))
  10.         ReDim crr(1 To 2, 1 To UBound(arr_col, 2))
  11.         For i = 1 To UBound(arr_row)
  12.             iMax = 0: iMin = 99
  13.             For j = 1 To UBound(arr_col, 2)
  14.                 If arr_col(1, j) = arr_row(i, 1) Then
  15.                     If Len(brr(i, j)) > 0 Then
  16.                         If brr(i, j) = WorksheetFunction.Max(WorksheetFunction.Index(brr, 0, j)) Then
  17.                             crr(1, j) = i
  18.                         End If
  19.                         If brr(i, j) = WorksheetFunction.Min(WorksheetFunction.Index(brr, 0, j)) Then
  20.                             crr(2, j) = i
  21.                         End If
  22.                     End If
  23.                 End If
  24.             Next
  25.         Next
  26.         For j = 1 To UBound(crr, 2)
  27.             If crr(1, j) > 0 Then
  28.                 If RngMax Is Nothing Then
  29.                     Set RngMax = .Cells(crr(1, j) + 16, j + 1)
  30.                 Else
  31.                     Set RngMax = Union(RngMax, .Cells(crr(1, j) + 16, j + 1))
  32.                 End If
  33.             End If
  34.             If crr(2, j) > 0 Then
  35.                 If RngMin Is Nothing Then
  36.                     Set RngMin = .Cells(crr(2, j) + 16, j + 1)
  37.                 Else
  38.                     Set RngMin = Union(RngMin, .Cells(crr(2, j) + 16, j + 1))
  39.                 End If
  40.             End If
  41.         Next
  42.     End With
  43.     RngMax.Interior.ColorIndex = 3
  44.     RngMin.Interior.ColorIndex = 41
  45. End Sub
复制代码

left369.zip

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

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
left369
 楼主| 发表于 2014-5-31 15:40 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
有人么，老师。
回复

使用道具 举报

fffox
发表于 2014-5-31 16:29 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
请测试：
  1. Option Explicit

  3. Sub test()
  4.     Dim arr_col, arr_row, brr, crr(), iMax%, iMin%
  5.     Dim i%, j%, RngMax As Range, RngMin As Range
  6.     With Sheets(1)
  7.         arr_row = .Range("a17:a26")
  8.         arr_col = .Range("b13", Cells(13, Cells(13, Columns.Count).End(1).Column))
  9.         brr = .Range("b17").Resize(UBound(arr_row), UBound(arr_col, 2))
  10.         ReDim crr(1 To UBound(arr_row), 1 To 2)
  11.         For i = 1 To UBound(arr_row)
  12.             iMax = 0: iMin = 99
  13.             For j = 1 To UBound(arr_col, 2)
  14.                 If arr_col(1, j) = arr_row(i, 1) Then
  15.                     If Len(brr(i, j)) > 0 Then
  16.                         If brr(i, j) > iMax Then
  17.                             iMax = brr(i, j)
  18.                             crr(i, 1) = j
  19.                         End If
  20.                         If brr(i, j) < iMin Then
  21.                             iMin = brr(i, j)
  22.                             crr(i, 2) = j
  23.                         End If
  24.                     End If
  25.                 End If
  26.             Next
  27.         Next
  28.         Set RngMax = .Cells(17, crr(1, 1) + 1)
  29.         Set RngMin = .Cells(17, crr(1, 2) + 1)
  30.         For i = 2 To UBound(crr)
  31.             Set RngMax = Union(RngMax, .Cells(16 + i, crr(i, 1) + 1))
  32.             Set RngMin = Union(RngMin, .Cells(16 + i, crr(i, 2) + 1))
  33.         Next
  34.     End With
  35.     RngMax.Interior.ColorIndex = 3
  36.     RngMin.Interior.ColorIndex = 41
  37. End Sub
复制代码
回复

使用道具 举报

left369
 楼主| 发表于 2014-5-31 16:50 | 显示全部楼层
fffox 发表于 2014-5-31 16:29
请测试：

你好，老师。我没表述清楚哦。不好意思。再做了几个例子。老师看看。

left369222.zip

9.71 KB, 下载次数: 5
回复

使用道具 举报

fffox
发表于 2014-5-31 18:04 | 显示全部楼层    本楼为最佳答案   
left369 发表于 2014-5-31 16:50
你好，老师。我没表述清楚哦。不好意思。再做了几个例子。老师看看。

再看一下：
  1. Option Explicit

  3. Sub test()
  4.     Dim arr_col, arr_row, brr, crr(), iMax%, iMin%
  5.     Dim i%, j%, RngMax As Range, RngMin As Range
  6.     With Sheets(1)
  7.         arr_row = .Range("a17:a26")
  8.         arr_col = .Range("b13", Cells(13, Cells(13, Columns.Count).End(1).Column))
  9.         brr = .Range("b17").Resize(UBound(arr_row), UBound(arr_col, 2))
  10.         ReDim crr(1 To 2, 1 To UBound(arr_col, 2))
  11.         For i = 1 To UBound(arr_row)
  12.             iMax = 0: iMin = 99
  13.             For j = 1 To UBound(arr_col, 2)
  14.                 If arr_col(1, j) = arr_row(i, 1) Then
  15.                     If Len(brr(i, j)) > 0 Then
  16.                         If brr(i, j) = WorksheetFunction.Max(WorksheetFunction.Index(brr, 0, j)) Then
  17.                             crr(1, j) = i
  18.                         End If
  19.                         If brr(i, j) = WorksheetFunction.Min(WorksheetFunction.Index(brr, 0, j)) Then
  20.                             crr(2, j) = i
  21.                         End If
  22.                     End If
  23.                 End If
  24.             Next
  25.         Next
  26.         For j = 1 To UBound(crr, 2)
  27.             If crr(1, j) > 0 Then
  28.                 If RngMax Is Nothing Then
  29.                     Set RngMax = .Cells(crr(1, j) + 16, j + 1)
  30.                 Else
  31.                     Set RngMax = Union(RngMax, .Cells(crr(1, j) + 16, j + 1))
  32.                 End If
  33.             End If
  34.             If crr(2, j) > 0 Then
  35.                 If RngMin Is Nothing Then
  36.                     Set RngMin = .Cells(crr(2, j) + 16, j + 1)
  37.                 Else
  38.                     Set RngMin = Union(RngMin, .Cells(crr(2, j) + 16, j + 1))
  39.                 End If
  40.             End If
  41.         Next
  42.     End With
  43.     RngMax.Interior.ColorIndex = 3
  44.     RngMin.Interior.ColorIndex = 41
  45. End Sub
复制代码
回复

使用道具 举报

fffox
发表于 2014-5-31 20:40 | 显示全部楼层
left369 发表于 2014-5-31 16:50
你好，老师。我没表述清楚哦。不好意思。再做了几个例子。老师看看。

楼主的要求是最大、最小值在同一列内不能重复。再修改一下代码：
  1. Option Explicit

  3. Sub test()
  4.     Dim arr_col, arr_row, brr, crr(), iMax%, iMin%
  5.     Dim i%, j%, k%, x%, RngMax As Range, RngMin As Range
  6.     With Sheets(1)
  7.         arr_row = .Range("a17:a26")
  8.         arr_col = .Range("b13", Cells(13, Cells(13, Columns.Count).End(1).Column))
  9.         brr = .Range("b17").Resize(UBound(arr_row), UBound(arr_col, 2))
  10.         ReDim crr(1 To 2, 1 To UBound(arr_col, 2))
  11.         For i = 1 To UBound(arr_row)
  12.             iMax = 0: iMin = 99
  13.             For j = 1 To UBound(arr_col, 2)
  14.                 If arr_col(1, j) = arr_row(i, 1) Then
  15.                     If Len(brr(i, j)) > 0 Then
  16.                         If brr(i, j) = WorksheetFunction.Max(WorksheetFunction.Index(brr, 0, j)) Then
  17.                             k = 0
  18.                             For x = 1 To UBound(arr_row)
  19.                                 If brr(x, j) = brr(i, j) Then k = k + 1
  20.                             Next
  21.                             If k = 1 Then crr(1, j) = i
  22.                         End If
  23.                         If brr(i, j) = WorksheetFunction.Min(WorksheetFunction.Index(brr, 0, j)) Then
  24.                             k = 0
  25.                             For x = 1 To UBound(arr_row)
  26.                                 If brr(x, j) = brr(i, j) Then k = k + 1
  27.                             Next
  28.                             If k = 1 Then crr(2, j) = i
  29.                         End If
  30.                     End If
  31.                 End If
  32.             Next
  33.         Next
  34.         For j = 1 To UBound(crr, 2)
  35.             If crr(1, j) > 0 Then
  36.                 If RngMax Is Nothing Then
  37.                     Set RngMax = .Cells(crr(1, j) + 16, j + 1)
  38.                 Else
  39.                     Set RngMax = Union(RngMax, .Cells(crr(1, j) + 16, j + 1))
  40.                 End If
  41.             End If
  42.             If crr(2, j) > 0 Then
  43.                 If RngMin Is Nothing Then
  44.                     Set RngMin = .Cells(crr(2, j) + 16, j + 1)
  45.                 Else
  46.                     Set RngMin = Union(RngMin, .Cells(crr(2, j) + 16, j + 1))
  47.                 End If
  48.             End If
  49.         Next
  50.     End With
  51.     If Not RngMax Is Nothing Then RngMax.Interior.ColorIndex = 3
  52.     If Not RngMin Is Nothing Then RngMin.Interior.ColorIndex = 41
  53. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-5-2 13:33 , Processed in 0.140527 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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