Excel精英培训网

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

[已解决]黄绿红统计1

[复制链接]
发表于 2014-1-15 21:13 | 显示全部楼层 |阅读模式
本帖最后由 wszbd 于 2014-1-17 14:24 编辑

黄绿红统计1.rar (6.59 KB, 下载次数: 12)
 楼主| 发表于 2014-1-16 21:42 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2014-1-17 03:22 | 显示全部楼层
回复

使用道具 举报

发表于 2014-1-17 10:07 | 显示全部楼层    本楼为最佳答案   
Sub Test()
    Dim rng As Range                            '数据源
    Dim rc(1 To 4) As Integer                   '数据源范围
    Dim x As Integer                            '当前色值
    Dim y As Integer                            '当前间隔数
    Dim i As Integer, j As Integer

    Sheet1.Activate
    Set rng = [d3:z12]
    rc(1) = rng.Row                             '首行
    rc(2) = rng.Row + rng.Rows.Count - 1        '末行
    rc(3) = rng.Column                          '首列
    rc(4) = rng.Column + rng.Columns.Count - 1  '末列
    ReDim B(rc(1) To rc(2), 1 To 6)

    For i = rc(1) To rc(2)
        ReDim A(3 To 10, 1 To 3)                '次数、上次列号、最大间隔数
        For j = rc(3) To rc(4)
            x = Cells(i, j).Interior.ColorIndex
            If x > 2 Then
                A(x, 1) = A(x, 1) + 1
                If A(x, 1) > 1 Then
                    y = j - A(x, 2) - 1         '当前间隔数
                    If y > A(x, 3) Then A(x, 3) = y
                End If
                A(x, 2) = j
            End If
        Next j
        B(i, 1) = A(6, 1): B(i, 2) = A(6, 3)    '黄6
        B(i, 3) = A(10, 1): B(i, 4) = A(10, 3)  '绿10
        B(i, 5) = A(3, 1): B(i, 6) = A(3, 3)    '红3
    Next i
   
    [j18].Resize(UBound(B) - LBound(B) + 1, UBound(B, 2)) = B
End Sub
黄绿红统计1b.rar (17.5 KB, 下载次数: 10)
回复

使用道具 举报

发表于 2014-1-17 10:09 | 显示全部楼层
测试正确后,改为实际数据源
Set rng = [d3:ip12]
回复

使用道具 举报

发表于 2014-1-17 10:51 | 显示全部楼层
没做测试,你自己检验一下吧
  1. Private Sub CommandButton1_Click()
  2. Dim arr, i&, j&, r&, c&, YMax&, RMax&, GMax&
  3. r = [d3].CurrentRegion.Rows.Count
  4. c = [d3].CurrentRegion.Columns.Count
  5. [j18].Resize(r, 6).ClearContents
  6. ReDim arr(1 To r, 1 To 6)
  7. For i = 1 To r
  8.   For j = 1 To c
  9.     If Cells(i + 2, j + 3).Interior.ColorIndex = 6 Then arr(i, 1) = arr(i, 1) + 1: arr(i, 2) = Application.Max(arr(i, 2), j - YMax - 1): YMax = j
  10.     If Cells(i + 2, j + 3).Interior.ColorIndex = 3 Then arr(i, 5) = arr(i, 5) + 1: arr(i, 6) = Application.Max(arr(i, 6), j - RMax - 1): RMax = j
  11.     If Cells(i + 2, j + 3).Interior.ColorIndex = 10 Then arr(i, 3) = arr(i, 3) + 1: arr(i, 4) = Application.Max(arr(i, 4), j - GMax - 1): GMax = j
  12.   Next j
  13.   YMax = 0: RMax = 0: GMax = 0
  14. Next i
  15. [j18].Resize(r, 6) = arr
  16. End Sub
复制代码

黄绿红统计1.zip

17.87 KB, 下载次数: 2

回复

使用道具 举报

 楼主| 发表于 2014-1-17 14:25 | 显示全部楼层
爱疯 发表于 2014-1-17 10:07
Sub Test()
    Dim rng As Range                            '数据源
    Dim rc(1 To 4) As Integer   ...

太完美了,谢谢!!!
回复

使用道具 举报

 楼主| 发表于 2014-1-17 14:29 | 显示全部楼层
大灰狼1976 发表于 2014-1-17 10:51
没做测试,你自己检验一下吧

谢谢“大灰狼”老师!!!

“爱疯”老师做的非常完美。源数据区域修改起来非常方便。无论是断行,还是断列,都不影响结果。
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 23:51 , Processed in 0.831760 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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