填充颜色的代码谢谢

arrEH

找数字填色

arrEH

再顶一下。。。。。。

一把小刀闯天下

'消息收到

'示例结果可能是错的或条件为最后第二个，注释行输出后用你的慧眼确认一下，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, n, t
  Cells.Interior.ColorIndex = xlNone
  For i = 1 To 42 Step 14
    n = 0
    arr = Cells(42, i).CurrentRegion
    For j = 1 To UBound(arr, 1)
      For k = 1 To UBound(arr, 2) - 1
        For kk = k + 1 To UBound(arr, 2)
          If arr(j, k) < arr(j, kk) Then
            t = arr(j, k): arr(j, k) = arr(j, kk): arr(j, kk) = t
          End If
      Next kk, k
      If n < arr(j, UBound(arr, 2) - 2) Then n = arr(j, UBound(arr, 2) - 2) '可能为最后第二个（改为-1）
    Next
'    Cells(42, i + 42).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    For j = 66 To Cells(Rows.Count, i).End(xlUp).Row
      If Cells(j, i) >= n Then Cells(j, i).Interior.Color = vbRed: Exit For
  Next j, i
End Sub

一把小刀闯天下

审核中，没事暖暖手指吧，，，

arrEH

一把小刀闯天下 发表于 2019-3-16 17:14
审核中，没事暖暖手指吧，，，

你好老师，效果是对的。想问下：
如果是每行10个数至少有3个数小于要找的数，代码在哪里修改呢？

arrEH

一把小刀闯天下 发表于 2019-3-16 17:14
审核中，没事暖暖手指吧，，，

您好小刀老师~ 第2组有时会出现错误，麻烦老师再看下哦

一把小刀闯天下

arrEH 发表于 2019-3-16 20:10
您好小刀老师~ 第2组有时会出现错误，麻烦老师再看下哦

换了一种判断方法，，，

Sub test()
  Dim arr, i, j, k, kk, n, t
  Cells.Interior.ColorIndex = xlNone
  For i = 1 To 42 Step 14
    n = 0
    arr = Cells(42, i).Resize(22, 10)
    For j = 1 To UBound(arr, 1)
      For k = 1 To UBound(arr, 2) - 1
        For kk = k + 1 To UBound(arr, 2)
          If arr(j, k) < arr(j, kk) Then
            t = arr(j, k): arr(j, k) = arr(j, kk): arr(j, kk) = t
          End If
      Next kk, k
      If n < arr(j, UBound(arr, 2) - 1) Then n = arr(j, UBound(arr, 2) - 1) '大于最后2个（-1），3个（-2），，，
    Next
    Cells(42, i + 42).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    For j = 66 To Cells(Rows.Count, i).End(xlUp).Row
      If Cells(j, i) > n Then Cells(j, i).Interior.Color = vbRed: Exit For
  Next j, i
End Sub

一把小刀闯天下

'审核中，修改的很少自己对照改一下，，，

arrEH

一把小刀闯天下 发表于 2019-3-16 20:47
'审核中，修改的很少自己对照改一下，，，

老师看下6楼附件的第2组，填充错误，不知道什么原因？第1组对，第2组会出错。

一把小刀闯天下

arrEH 发表于 2019-3-16 20:59
老师看下6楼附件的第2组，填充错误，不知道什么原因？第1组对，第2组会出错。

找数字3333.rar (22.91 KB, 下载次数: 28)

2019-3-16 21:04 上传

点击文件名下载附件

7楼的代码就是针对6楼问题修改的，你都懒得敲几个字符？算了还是给你上传附件吧！