請問如何在一欄數字當中 最大值 次大值 第三大值 設不同底色

peter95

下載 (270.54 KB)
說明

2016-4-1 00:21

請問如何在一欄數字當中  最大值 次大值 第三大值 設不同底色
最大值   底色 設為 紅色
第二大值 底色 設為 淺藍
第三大值 底色 設為 黃色

感謝大家的幫忙
謝謝

luhpro

回復 1# peter95
先選取 A1 到 A30(請依實際情修改末列列號) 儲存格, 再依底下圖片內容設定即可.

下載 (56.21 KB)

2016-4-1 03:31

peter95

回復 2# luhpro

感謝回復

請問 有辦法寫成VBA嗎
還有 我執行 不出來
請在幫幫我
感謝

GBKEE

回復 3# peter95
VBA 參考這裡    http://forum.twbts.com/thread-16926-1-1.html

Kubi

另外提供幾種色彩標示法做參考：

一、先[給值](產生新樣本)，以方便做測試
二、利用[輔助欄排序法]來填色
三、利用[輔助欄非排序法]來填色
四、利用[陣列法]來填色
五、[排序]是作為填色後，方便資料驗證之用
六、如用字點檔(Dictionary)來填色也可盡功，請自行撰寫

底下就式程式碼拙作：

Option Base 1

Sub 給值()
    Randomize
    Cells.Interior.ColorIndex = xlNone
    Cells.ClearContents
    er = Int(Rnd * 100) + 10
    Application.ScreenUpdating = False
    For c = 1 To Int(Rnd * 10) + 2
        For r = 1 To er
            Cells(r, c).Value = Int(Rnd * 1000)
        Next r
    Next c
    Application.ScreenUpdating = True
End Sub

Sub 輔助欄排序法()
    ci = Array(3, 8, 6)
    er = [A1].CurrentRegion.Rows.Count
    ec = [A1].CurrentRegion.Columns.Count + 1
    Application.ScreenUpdating = False
    For i = 1 To er
        Cells(i, ec).Value = i
    Next i
    For c = 1 To ec - 1
        Range(Cells(1, c), Cells(er, ec)).Sort key1:=Cells(1, c), order1:=2
        x = -1
        n = -1
        For Each cell In Cells(1, c).Resize(er)
            If cell.Value <> n Then
                n = cell.Value
                x = x + 1
                If x = 3 Then Exit For
                cell.Interior.ColorIndex = ci(x + 1)
            Else
                cell.Interior.ColorIndex = ci(x + 1)
            End If
        Next cell
        Range(Cells(1, c), Cells(er, ec)).Sort key1:=Cells(1, ec), order1:=1
    Next c
    Columns(ec).ClearContents
    Application.ScreenUpdating = True
End Sub

Sub 輔助欄非排序法()
    ci = Array(3, 8, 6)
    er = [A1].CurrentRegion.Rows.Count
    ec = [A1].CurrentRegion.Columns.Count
    Application.ScreenUpdating = False
    For c = 1 To ec
        Range(Cells(1, ec + 1), Cells(er, ec + 2)).ClearContents
        For r = 1 To er
            For i = 1 To 3
                If Cells(i, ec + 1).Value = "" Then
                    Cells(i, ec + 1).Value = Cells(r, c).Value
                    Cells(i, ec + 2).Value = Trim(r)
                    Exit For
                Else
                    If Cells(r, c).Value = Cells(i, ec + 1).Value Then
                        Cells(i, ec + 2).Value = Cells(i, ec + 2).Value & "," & Trim(r)
                        Exit For
                    Else
                        If Cells(r, c).Value > Cells(i, ec + 1).Value Then
                            Range(Cells(i, ec + 1), Cells(i, ec + 2)).Insert Shift:=xlDown
                            Cells(i, ec + 1).Value = Cells(r, c).Value
                            Cells(i, ec + 2).Value = Trim(r)
                            Exit For
                        End If
                    End If
                End If
            Next i
        Next r
        For i = 1 To 3
            n = Split(Cells(i, ec + 2).Value, ",")
            For j = 0 To UBound(n)
                Cells(n(j), c).Interior.ColorIndex = ci(i)
            Next j
        Next i
    Next c
    Range(Cells(1, ec + 1), Cells(er, ec + 2)).ClearContents
    Application.ScreenUpdating = True
End Sub

Sub 陣列法()
    Dim arr
    Dim brr()
    ci = Array(3, 8, 6)
    arr = [A1].CurrentRegion
    ec = UBound(arr, 2)
    er = UBound(arr)
    For c = 1 To ec
        ReDim brr(3, 2)
        For r = 1 To er
            n = arr(r, c)
            For i = 1 To 3
                If n = brr(i, 1) Then
                    brr(i, 2) = brr(i, 2) & "," & r
                    Exit For
                End If
                If brr(i, 1) = "" Then
                    brr(i, 1) = n
                    brr(i, 2) = r
                    Exit For
                Else
                    If n > brr(i, 1) Then
                        For j = 3 To i + 1 Step -1
                            brr(j, 1) = brr(j - 1, 1)
                            brr(j, 2) = brr(j - 1, 2)
                        Next j
                        brr(i, 1) = n
                        brr(i, 2) = r
                        Exit For
                    End If
                End If
            Next i
        Next r
        For i = 1 To 3
            x = Split(brr(i, 2), ",")
            For j = 0 To UBound(x)
                Cells(x(j), c).Interior.ColorIndex = ci(i)
            Next j
        Next i
    Next c
End Sub

Sub 排序()
    ec = [A1].End(2).Column
    er = [A65536].End(3).Row
    Application.ScreenUpdating = False
    For c = 1 To ec
        Range(Cells(1, c), Cells(er, c)).Sort key1:=Cells(1, c), order1:=2
    Next c
    Application.ScreenUpdating = True
End Sub

准提部林

前三大都不只一個，如何處理？
１００
９９
１００
９９
９９
８５
７０
７６

frantz

請問
這個用函數跟VBA寫，兩者的差異性在那裡??
那一種對資源負擔會比較大一點??

peter95

回復 5# Kubi

感謝大大  熱請幫忙
小弟執行時 發現狀況

下載 (72.9 KB)

2016-4-12 01:52

輔助欄非排序法
黃色地方顯示錯誤 然後當掉

請大大 再幫我看看
附上小弟 要篩選的檔案
Book1.rar (6.09 KB)

下載次數: 5

2016-4-12 01:52

再次感謝 各位 大大的幫忙
謝謝

GBKEE

回復 8# peter95
上傳檔案 xlsx 是無巨集沒有程式碼,需上傳副檔名xlsm有巨集程式碼.

1. Option Explicit
   
2. Option Base 0
   
3. Sub Ex_()
   
4.     'Option Base 陳述式 在模組層次中用來宣告陣列索引的預設下限。
   
5.     'Option Base {0 | 1}
   
6.     '陣列元素下限值,預設為 Option Base 0
   
7.     ' 預設值  For I = 0 To 2  '才正確
   
8.     '有 Option Base  1   For I = 1 To 3 '是正確
   
9.     '不管有無  Option Base
   
10.     '保險作法  For I = LBound(ci) To UBound(ci)
    
11.    ' Dim ci(5 To 7), i As Integer
    
12.    ' ci(5) = 3
    
13.    ' ci(6) = 8
    
14.    ' ci(7) = 6
    
15.     Dim ci(), i As Integer
    
16.     ci = Array(3, 8, 6)
    
17.    
    
18.     MsgBox " ci 下限值 " & LBound(ci) & " ci 上限值 " & UBound(ci)
    
19.     For i = LBound(ci) To UBound(ci)
    
20.         MsgBox ci(i)
    
21.     Next
    
22. End Sub

複製代碼

准提部林

先試[格式化條件]：
http://www.funp.net/116242

如果前三大不只一個，如何標色？