[已解决]按规律填充背景色

爱疯

plepwsOK.rar (14.5 KB, 下载次数: 6)

2010-12-7 11:58 上传

点击文件名下载附件
按规律填充背景色

[此贴子已经被作者于2010-12-7 15:32:12编辑过]

最佳答案

月排行榜 / 总排行榜

amulee

2010-12-7 15:49

颜色部分你自己处理吧。
我用了随机的
Sub Test()
    Dim Rng As Range
    Dim Arr
    Dim i&, j&
    Dim lStart&, lEnd&
    Set Rng = Sheet1.Range("A1:D" & Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row)
    '先排序
    Rng.Sort Key1:=Range("D1"), Order1:=xlAscending, Key2:=Range("B1") _
        , Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending, Header:=xlNo
    Arr = Rng.Value
    '先找2
    For i = 1 To UBound(Arr)
        If Arr(i, 3) = 2 Then
            lStart = i
            Exit For
        End If
    Next i
    '没有找到则退出
    If lStart = 0 Then Exit Sub
    '开始着色
    For i = lStart + 1 To UBound(Arr)
        '找到不同
        If Arr(i, 2) & Arr(i, 3) <> Arr(i - 1, 2) & Arr(i - 1, 3) Then
            lEnd = i - 1 '给终点赋值
            '变颜色
            Sheet1.Range(Sheet1.Cells(lStart, 1), Sheet1.Cells(lEnd, 4)).Interior.Color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
            '设置新的起点
            lStart = i
        End If
   
    Next i
    '判断最后一行。如果lEnd比lStart小的话，证明最后的区域没有变色
    '原因是，该区域光有起点。而终点是前一个区域的终点，肯定比新区域的起点小
    If lEnd < lStart Then
        lEnd = UBound(Arr)
        Sheet1.Range(Sheet1.Cells(lStart, 1), Sheet1.Cells(lEnd, 4)).Interior.Color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
    End If
End Sub

跳转到最佳答案楼层

爱疯

A,B,C为数据源，D列为要计算的结果,D是这么来的：

Sub A()

    Dim Arr() As Variant    '数据源
    Dim ArrJG() As Variant  '结果
    Dim DicA As Object    'B列&C列作关键字，分类统计重复次数
    Dim DicB As Object    'B列&C列作关键字，分类累计字符串
    Dim i As Long
    Dim Str As String     '临时字符串

    Arr = Range("A1:C" & Range("A1").End(xlDown).Row).Value
    ReDim ArrJG(1 To UBound(Arr), 1 To 1)
    Set DicA = CreateObject("scripting.dictionary")
    Set DicB = CreateObject("scripting.dictionary")

    For i = 1 To UBound(Arr)
        Str = Arr(i, 2) & "|" & Arr(i, 3)
        DicA(Str) = DicA(Str) + 1
        DicB(Str) = DicB(Str) & Arr(i, 1)
    Next i
    For i = 1 To UBound(Arr)
        Str = Arr(i, 2) & "|" & Arr(i, 3)
        If DicA(Str) = 2 And InStr(DicB(Arr(i, 3)), "@iptv") Then
            ArrJG(i, 1) = 1
        Else
            ArrJG(i, 1) = DicA(Str)
        End If
    Next i

    Range("D1").Resize(UBound(ArrJG), 1) = ArrJG
    Set DicA = Nothing
    Set DicB = Nothing

End Sub

修改或增加a()，或产生辅助列，有利于解答1楼问题吗？

amulee

B&C?
你第二行和第一行就不相同，怎么没改颜色？

爱疯

我觉得，
2楼和本题无关，可不看；
当1楼问题解决遇上困难时，2楼介绍或许有用。

谢谢阿木！

不好意思，1楼我叙述错误，修改了。以1楼图2来介绍：

只需从D列为2的行开始比较，分表填充两种颜色。首先，第4行填充颜色1：

• B4&C4 与 B5&C5 相同，所以第5行填充上行颜色（颜色1）
• B5&C5 与 B6&C6 不同，所以第6行填充非上行颜色（颜色2）
• B6&C6 与 B7&C7 相同，所以第7行填充上行颜色（颜色2）
• ......

PS:不知我都说清了么[em04]

amulee

颜色部分你自己处理吧。
我用了随机的
Sub Test()
    Dim Rng As Range
    Dim Arr
    Dim i&, j&
    Dim lStart&, lEnd&
    Set Rng = Sheet1.Range("A1:D" & Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row)
    '先排序
    Rng.Sort Key1:=Range("D1"), Order1:=xlAscending, Key2:=Range("B1") _
        , Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending, Header:=xlNo
    Arr = Rng.Value
    '先找2
    For i = 1 To UBound(Arr)
        If Arr(i, 3) = 2 Then
            lStart = i
            Exit For
        End If
    Next i
    '没有找到则退出
    If lStart = 0 Then Exit Sub
    '开始着色
    For i = lStart + 1 To UBound(Arr)
        '找到不同
        If Arr(i, 2) & Arr(i, 3) <> Arr(i - 1, 2) & Arr(i - 1, 3) Then
            lEnd = i - 1 '给终点赋值
            '变颜色
            Sheet1.Range(Sheet1.Cells(lStart, 1), Sheet1.Cells(lEnd, 4)).Interior.Color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
            '设置新的起点
            lStart = i
        End If
   
    Next i
    '判断最后一行。如果lEnd比lStart小的话，证明最后的区域没有变色
    '原因是，该区域光有起点。而终点是前一个区域的终点，肯定比新区域的起点小
    If lEnd < lStart Then
        lEnd = UBound(Arr)
        Sheet1.Range(Sheet1.Cells(lStart, 1), Sheet1.Cells(lEnd, 4)).Interior.Color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
    End If
End Sub

爱疯

谢谢阿木！

测了一个68000多行的，速度很快，真高兴啊，严重学习！！我修改了两处：

1、If Arr(i, 3) = 2 Then，改为了If Arr(i, 4) = 2 Then

    举的例题中，由于巧合，没发现出错误。如果不改，就退出了。

2、所有的sheet1，都改为了sheets("sheet1")。如果不改，就会出现下图的提示。不知和加载宏是否有关？反正改了后没出现了。

按规律填充背景色

PS：这个随机颜色的效果，比我原想的更好，更便于他人查看

[em25][em25]