Excel精英培训网

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

[已解决]单元格连续无空白判断

[复制链接]
发表于 2017-8-2 14:51 | 显示全部楼层 |阅读模式
数据表的数据,每组都是等同14行数据组,每组隔3个空白行
每组3个分析要求:
1:从下往上垂直连续9行以上无空格判断并上色
2:从左下往右上斜势连续9行以上无空格判断并上色
3:从右下往左上斜势连续9行以上无空格判断并上色

4:清除要求:没有判断颜色的数据组要求全部清除

最佳答案
2017-8-4 16:15
Option Explicit
Dim n, c, w, h

Sub test()
    Dim i
    Cells.Interior.ColorIndex = xlNone
    n = 9       '连续
    c = 24      '列号
    w = 24      '宽
    h = 13      '高
    For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row Step 17
        Call test2(i)
        Call test3(i)
        Call test4(i)
    Next i
End Sub

'从上到下
Sub test2(x)
    Dim i, j, Rng As Range
    For j = 1 To w
        For i = 1 To h - n + 1
            Set Rng = Cells(x + i - 1, w + j - 1).Resize(n)
            If Application.CountA(Rng) = n Then Rng.Interior.ColorIndex = 6
        Next i
    Next j
End Sub

'从左下到右上
Sub test3(x)
    Dim i, j, k, Rng As Range, addr$
    For j = c To c + w - 1
        For i = x + h - 1 To x + n - 1 Step -1
            '''''''''''''''''''''''''''''''''''''''''''''
            addr = ""
            For k = 1 To n
                Set Rng = Cells(i, j)(-1 * k + 2, k)
                If Rng <> "" Then addr = addr & "," & Rng.Address Else Exit For
            Next k
            addr = Mid(addr, 2)
            If k > n Then Range(addr).Interior.ColorIndex = 3
            '''''''''''''''''''''''''''''''''''''''''''''
        Next i
    Next j
End Sub

'从右下到左上
Sub test4(x)
    Dim i, j, k, Rng As Range, addr$
    For j = c + w - 1 To c Step -1
        For i = x + h - 1 To x + n - 1 Step -1
            '''''''''''''''''''''''''''''''''''''''''''''
            addr = ""
            For k = 1 To n
                Set Rng = Cells(i, j)(-1 * k + 2, -1 * k + 2)
                If Rng <> "" Then addr = addr & "," & Rng.Address Else Exit For
            Next k
            addr = Mid(addr, 2)
            If k > n Then Range(addr).Interior.ColorIndex = 4
            '''''''''''''''''''''''''''''''''''''''''''''
        Next i
    Next j
End Sub
2.rar (140.2 KB, 下载次数: 7)

新建 Microsoft Excel 工作表.rar

134.44 KB, 下载次数: 8

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-8-4 16:15 | 显示全部楼层    本楼为最佳答案   
Option Explicit
Dim n, c, w, h

Sub test()
    Dim i
    Cells.Interior.ColorIndex = xlNone
    n = 9       '连续
    c = 24      '列号
    w = 24      '宽
    h = 13      '高
    For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row Step 17
        Call test2(i)
        Call test3(i)
        Call test4(i)
    Next i
End Sub

'从上到下
Sub test2(x)
    Dim i, j, Rng As Range
    For j = 1 To w
        For i = 1 To h - n + 1
            Set Rng = Cells(x + i - 1, w + j - 1).Resize(n)
            If Application.CountA(Rng) = n Then Rng.Interior.ColorIndex = 6
        Next i
    Next j
End Sub

'从左下到右上
Sub test3(x)
    Dim i, j, k, Rng As Range, addr$
    For j = c To c + w - 1
        For i = x + h - 1 To x + n - 1 Step -1
            '''''''''''''''''''''''''''''''''''''''''''''
            addr = ""
            For k = 1 To n
                Set Rng = Cells(i, j)(-1 * k + 2, k)
                If Rng <> "" Then addr = addr & "," & Rng.Address Else Exit For
            Next k
            addr = Mid(addr, 2)
            If k > n Then Range(addr).Interior.ColorIndex = 3
            '''''''''''''''''''''''''''''''''''''''''''''
        Next i
    Next j
End Sub

'从右下到左上
Sub test4(x)
    Dim i, j, k, Rng As Range, addr$
    For j = c + w - 1 To c Step -1
        For i = x + h - 1 To x + n - 1 Step -1
            '''''''''''''''''''''''''''''''''''''''''''''
            addr = ""
            For k = 1 To n
                Set Rng = Cells(i, j)(-1 * k + 2, -1 * k + 2)
                If Rng <> "" Then addr = addr & "," & Rng.Address Else Exit For
            Next k
            addr = Mid(addr, 2)
            If k > n Then Range(addr).Interior.ColorIndex = 4
            '''''''''''''''''''''''''''''''''''''''''''''
        Next i
    Next j
End Sub
2.rar (140.2 KB, 下载次数: 7)
回复

使用道具 举报

发表于 2017-8-11 15:59 | 显示全部楼层
爱疯 发表于 2017-8-4 16:15
Option Explicit
Dim n, c, w, h

老师你好,不能给你发消息(需要好友,嘿嘿),只能给你回帖。是这样的论坛前些天 (论坛热图)里有两个根据日期画线的帖子怎么也找不到了,刚好要做这方面的工作,想学习一下,你有办法吗?输入相关的关键字都没找到,请老师帮下忙,谢谢。

回复

使用道具 举报

发表于 2017-8-11 16:07 | 显示全部楼层
02761752696 发表于 2017-8-11 15:59
老师你好,不能给你发消息(需要好友,嘿嘿),只能给你回帖。是这样的论坛前些天 (论坛热图)里有两个 ...

我也想不出好办法。

1)估计一下哪个版块?3选1
2)按新发帖时间排序,往后找
3)注意查看次数比较多的
回复

使用道具 举报

发表于 2017-8-11 16:19 | 显示全部楼层
爱疯 发表于 2017-8-11 16:07
我也想不出好办法。

1)估计一下哪个版块?3选1

好吧  谢谢老师  我把最新回复   最新热门都找了,热门有限制  ,只有最近的,我再找找吧

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 09:51 , Processed in 0.520390 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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