按某列填色

爱疯

填色2.rar (12.29 KB, 下载次数: 37)

2014-1-15 11:29 上传

点击文件名下载附件

在实际应用中，往往需要把结果按某列填色，以便查看。

1. ''作用：按某列填色（假设数据源左上角在A1）
   
2. '主程序
   
3. Sub FillColor()
   
4.     Dim k As Integer    'k=1才排序
   
5.     Dim y As Integer    '第几列
   
6.     Dim r As Long       '数据源行数
   
7.     Dim c As Integer    '数据源列数
   
8.     Application.ScreenUpdating = False
   
9.     k = 1: y = 4
   
10.     If k = 1 Then
    
11.         Call FillColor_Sort(y)
    
12.     Else
    
13.         r = Range("a1").CurrentRegion.Rows.Count
    
14.         c = Range("a1").CurrentRegion.Columns.Count
    
15.         '建辅助列，用于记录原顺序
    
16.         Cells(1, c + 1) = "辅助列"
    
17.         Cells(2, c + 1) = 1
    
18.         Cells(2, c + 1).AutoFill Destination:=Range(Cells(2, c + 1), Cells(r, c + 1)), Type:=xlFillSeries
    
19.         '填色并排序
    
20.         Call FillColor_Sort(y)
    
21.         '恢复原顺序
    
22.         Range("a1").CurrentRegion.Sort key1:=Cells(1, c + 1), order1:=xlAscending, Header:=xlYes
    
23.         '删辅助列
    
24.         Columns(c + 1).Delete
    
25.     End If
    
26. End Sub
    
27. 
    
28. '填色并排序
    
29. Sub FillColor_Sort(y As Integer)
    
30.     Dim A()         '数据源
    
31.     Dim x As Long   '当前填充区的末行行号
    
32.     Dim i As Long
    
33.     Range("a1").CurrentRegion.Sort key1:=Cells(1, y), order1:=xlAscending, Header:=xlYes    'j列升序
    
34.     A = Range("a1").CurrentRegion.Value
    
35.     x = UBound(A)
    
36.     For i = UBound(A) To 2 Step -1
    
37.         If A(i, y) <> A(i - 1, y) Then
    
38.             Range(Cells(i, 1), Cells(x, UBound(A, 2))).Interior.Color = _
    
39.             RGB(Rnd * 56 + 200, Rnd * 56 + 200, Rnd * 56 + 200)
    
40.             x = i - 1
    
41.         End If
    
42.     Next i
    
43. End Sub
    
44. 
    
45. '重置
    
46. Sub rst()
    
47.     Range("a2:e10").Interior.Color = xlNone
    
48.     Range("d2:d10") = "=char(int(RAND()*3)+97)"
    
49.     Range("d2:d10") = Range("d2:d10").Value
    
50. End Sub

复制代码

冥王

收藏备用  

爱疯

按某列填色3.rar (11.9 KB, 下载次数: 7)

2016-11-17 10:19 上传

点击文件名下载附件




'主程序
Sub fillColor()
    Dim isSort As Boolean, col, r, c
    Application.ScreenUpdating = False
    isSort = False               '是否排序，手动
    col = Range("d:d").Column    '指定列，手动
    If isSort Then
        Call fillAndSort(col)
    Else
        r = Range("a1").CurrentRegion.Rows.Count
        c = Range("a1").CurrentRegion.Columns.Count
        '建辅助列，用于记录原顺序
        Cells(1, c + 1) = "辅助列"
        Cells(2, c + 1) = 1
        Cells(2, c + 1).AutoFill Destination:=Range(Cells(2, c + 1), Cells(r, c + 1)), Type:=xlFillSeries
        '填色并排序
        Call fillAndSort(col)
        '恢复原顺序
        Range("a1").CurrentRegion.Sort key1:=Cells(1, c + 1), order1:=xlAscending, Header:=xlYes
        '删辅助列
        Columns(c + 1).Delete
    End If
End Sub

'填色并排序
Sub fillAndSort(col)
    Dim A, x, i
    Range("a1").CurrentRegion.Sort key1:=Cells(1, col), order1:=xlAscending, Header:=xlYes    '第j列排升序
    A = Range("a1").CurrentRegion: x = UBound(A)
    For i = UBound(A) To 2 Step -1
        If A(i, col) <> A(i - 1, col) Then
            Range(Cells(i, 1), Cells(x, UBound(A, 2))).Interior.Color = RGB(Rnd * 56 + 200, Rnd * 56 + 200, Rnd * 56 + 200)
            x = i - 1
        End If
    Next i
End Sub

爱疯

Sub FillColor()
    Dim IsSort As Boolean, i, j, k
    Application.ScreenUpdating = False
    IsSort = False              '是否排序（手动指定）
    k = Range("d:d").Column     '指定列（手动指定）

    If IsSort Then
        Call FillSort(k)
    Else
        i = Range("a1").CurrentRegion.Rows.Count
        j = Range("a1").CurrentRegion.Columns.Count + 1 '辅助列（手动指定）
        '1）记录
        Cells(1, j) = "辅助列"
        Cells(2, j) = 1
        Cells(2, j).AutoFill Destination:=Range(Cells(2, j), Cells(i, j)), Type:=xlFillSeries
        '2）改变
        Call FillSort(k)
        '3）恢复
        Range("a1").CurrentRegion.Sort key1:=Cells(1, j), order1:=xlAscending, Header:=xlYes
        Columns(j).Delete
    End If
End Sub

'填色并排序
Sub FillSort(k)
    Dim A, u, i
    Range("a1").CurrentRegion.Sort key1:=Cells(1, k), order1:=xlAscending, Header:=xlYes    'j列升序
    A = Range("a1").CurrentRegion
    u = UBound(A)
    For i = UBound(A) To 2 Step -1
        If A(i, k) <> A(i - 1, k) Then
            Range(Cells(i, 1), Cells(u, UBound(A, 2))).Interior.Color = RGB(Rnd * 56 + 200, Rnd * 56 + 200, Rnd * 56 + 200)
            u = i - 1
        End If
    Next i
End Sub

'重置
Sub Reset()
    Range("a2:e10").Interior.Color = xlNone
    Range("d2:d10") = "=char(int(RAND()*3)+65)"
    Range("d2:d10") = Range("d2:d10").Value
End Sub
按某列填色4.rar (12.01 KB, 下载次数: 0)

2017-12-28 16:00 上传

点击文件名下载附件