分享大家一点按填充颜色处理不连续区域的心得

muse123456

1.适用范围：
       在日常工作中处理表格的时候，要从原表中选取一些数据，这些数据在行列上不完全具有特殊的规律，使用Excel函数处理起来很麻烦甚至很难处理，但是目标数据在颜色（填充颜色或字体颜色）上有规律，适用以下方法。

2.方案描述：
Sub 后续整改分析表_上期()
    Dim 问题(), 整改() '定义两个数组变量
    Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer '定义i、j、k、l、m、n六个整数型控制变量
    Dim 问题底色分区 As Range, 整改底色分区 As Range, 问题单元格 As Range, 整改单元格 As Range '定义"问题底色分区"、"整改底色分区"、"问题单元格"、"整改单元格"四个区域型控制变量
    Dim 填充颜色 As Long, 问题区域 As Range, 整改区域 As Range, 问题底色区域 As Range, 整改底色区域 As Range '定义"填充颜色"为长整数型变量，"问题区域"、"整改区域"、"问题底色区域"、"整改底色区域"为区域型变量
'   如果目标颜色和目标区域发生变化，在以下简易修改
    填充颜色 = 10079487 '目标区域的填充颜色代码（浅土黄色）
    Set 问题区域 = Application.ActiveWorkbook.Worksheets("2013-2016").Range("G17:Q274") '区域型变量要用Set赋值
    Set 整改区域 = Application.ActiveWorkbook.Worksheets("2013-2016").Range("S17:W274") '区域型变量要用Set赋值
    k = 1 'k赋予初始值1，不赋值会出错，或者占用表头位置
    l = 1 'k赋予初始值1，不赋值会出错，或者占用表头位置
    For Each 问题单元格 In 问题区域 '对目标区域中的每一个单元格
        If 问题单元格.Interior.Color = 填充颜色 Then '如果单元格的填充颜色为目标颜色
            If 问题底色区域 Is Nothing Then '且，如果底色区域为空
                Set 问题底色区域 = 问题单元格 '则将单元格的值赋给"底色区域"变量
            Else '底色区域不为空（已经赋给了单元格的值了）
                Set 问题底色区域 = Union(问题底色区域, 问题单元格) '将当前底色区域的值（代表的区域）和单元格的值（代表的区域）进行合并，然后赋值给"底色区域变量"
            End If '结束If过程
        End If '结束If过程
    Next 问题单元格 '对目标区域中的所有单元格依次执行上述过程
'即便是合并后的区域，VBA也不作为连续区域处理，必须分区域处理（使用Areas属性）
    For Each 问题底色分区 In 问题底色区域.Areas
'   循环一次"底色分区"代表的区域的值就会覆盖原来数组的值，可以考虑 Redim Preserve 上期()，保留原来的数据，但一样要结合k = k + 1进行下一行的控制
        问题() = 问题底色分区.Value '将目标区域的值赋值给数组
        For j = LBound(问题, 2) To UBound(问题, 2) Step 2 '二维下界到二维上界的区间上，即列数，步长为2，即隔一列进行赋值
            For i = LBound(问题) To UBound(问题)  '一维下界到一维上界的区间上，即行数，步长为1（本例中行数的上下界为1）
                If Application.ActiveWorkbook.Worksheets("对比分析表").Range("e4").Offset(k, j) <> "" Then '如果赋值目标区域中有值
                    MsgBox "原表中有数，请删除" ''进行提示（原表中有数，不作本处理会提示下标越界）
                    Exit Sub '退出循环，不退出，在有值的情况下可能会陷入死循环，或者报错
                Else '如果赋值目标区域为空白
                    Application.ActiveWorkbook.Worksheets("对比分析表").Range("e4").Offset(k, j) = 问题(i, j) '将数组"上期"当前的值依次赋给目标区域
                End If '结束If过程
            Next i '对所有的i依次执行上述过程
        Next j '对所有的j依次执行上述过程
'   本程序控制目标区域换行的关键一步
        k = k + 1 '以上循环结束后，即本次"底色分区"代表的值已经全部赋值给对比分析表中空白区域的第k行，计数加1，使其在下一个循环中进入下一行
    Next 问题底色分区 '对所有的"底色分区"代表的区域依次执行上述过程
'   对整改区域的处理基本同上，区别在于赋值
    For Each 整改单元格 In 整改区域
        If 整改单元格.Interior.Color = 填充颜色 Then
            If 整改底色区域 Is Nothing Then
                Set 整改底色区域 = 整改单元格
            Else
                Set 整改底色区域 = Union(整改底色区域, 整改单元格)
            End If
        End If
    Next 整改单元格
    For Each 整改底色分区 In 整改底色区域.Areas
        整改() = 整改底色分区.Value
        For n = LBound(整改, 2) To UBound(整改, 2) '与问题部分的不同，步长为1
            For m = LBound(整改) To UBound(整改)
                If Application.ActiveWorkbook.Worksheets("对比分析表").Range("q4").Offset(l, 2 * n - 1) <> "" Then
                    MsgBox "原表中有数，请删除"
                    Exit Sub
                Else
                    Application.ActiveWorkbook.Worksheets("对比分析表").Range("q4").Offset(l, 2 * n - 1) = 整改(m, n) '将数组"上期"当前的值依次赋给目标区域
                End If
            Next m
        Next n
        l = l + 1
    Next 整改底色分区
End Sub '结束过程

3.心得说明
（1）使用Union函数得到的合并后的区域，VBA也不作为连续区域处理，必须分区域处理（使用Areas属性）
（2）对这种不连续区域求上界（Ubound函数），得到的结果很可能是最后一个区域的行数和列数，而这并不是我们想要的结果（可以参见John Walkenbach的《Excel 2010高级VBA编程宝典》附件中有专门解决不连续区域行数统计的问题）
（3）本例中，直接用自定义数组对目标区域赋值得到的结果是反复在同一区域赋值，最后只有第一行得到了结果，而且是分块区域的最后最后一个区域（因为Ubound()=1），解决的办法自认为比较取巧，添加了一个控制变量k、l，循环一次k、l的计数加1，结合Offset函数实现了自动换行赋值。

4.附加说明
（1）该过程未考虑可撤销的情况，固定模块，请自行研究
（2）该过程对原表中已有数据的情况采用提示用户自行删除的方式加以处理，其他方式请自行修改
（3）可以再写一个Sub过程，反复调用上述过程，以处理多年度的情况
（4）原表数据涉及内部资料，无法直接提供，以贴图作为附件展示
（5）本例中没有解决将两个不同特征的区域（问题区域和整改区域）合并的问题，整个代码比较繁琐、冗长，希望有大神能解惑

592rmb

好东西，工作中经常会用到