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

帖子: 163
主題: 1
精華: 0
積分: 170
點名: 0
作業系統: Window 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-9-5
最後登錄: 2022-7-20

5^# 跳轉到 »

發表於 2016-4-10 21:09 | 只看該作者

本帖最後由 Kubi 於 2016-4-10 21:11 編輯

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

一、先[給值](產生新樣本)，以方便做測試
二、利用[輔助欄排序法]來填色
三、利用[輔助欄非排序法]來填色
四、利用[陣列法]來填色
五、[排序]是作為填色後，方便資料驗證之用
六、如用字點檔(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

[b]Kubi[/b]

TOP

GBKEE