麻辣家族討論版版 - Powered by Discuz! Board

標題: 請問如何在一欄數字當中最大值次大值第三大值設不同底色 [打印本頁]

作者: peter95 時間: 2016-4-1 00:22 標題: 請問如何在一欄數字當中最大值次大值第三大值設不同底色

[attach]23671[/attach]

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

感謝大家的幫忙
謝謝

作者: luhpro 時間: 2016-4-1 03:31

本帖最後由 luhpro 於 2016-4-1 03:34 編輯

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

[attach]23673[/attach]

作者: peter95 時間: 2016-4-8 00:16

回復 2# luhpro

感謝回復

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

作者: GBKEE 時間: 2016-4-8 13:07

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

作者: Kubi 時間: 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

作者: 准提部林 時間: 2016-4-11 11:39

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

作者: frantz 時間: 2016-4-11 11:57

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

作者: peter95 時間: 2016-4-12 01:51

本帖最後由 peter95 於 2016-4-12 01:53 編輯

回復 5# Kubi

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

[attach]23814[/attach]
輔助欄非排序法
黃色地方顯示錯誤然後當掉

請大大再幫我看看
附上小弟要篩選的檔案
[attach]23813[/attach]
再次感謝各位大大的幫忙
謝謝

作者: GBKEE 時間: 2016-4-12 06:10

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

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

複製代碼

作者: 准提部林 時間: 2016-4-12 09:48

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

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

作者: mave 時間: 2016-4-12 11:42

回復 7# frantz
如果是常常有此類的文件類型要處理，
用VBA執行不用像函數每次都要設定一次。

以上是我的經驗
不知道有無錯誤
尚請各位大大指教

作者: Kubi 時間: 2016-4-12 20:50

回復 8# peter95
我的權限不能下載附件，因此無法了解您的問題出在哪裡？
可能誠如GBKEE超級版主所述原因可能出在於Option Base 1，
Option Base 1 必須放置於模組的頂端，宣告在此模組內的所有巨集的陣列其起始值是從1開始，並非從0開始，
若未定義Option Base，則預設是從0開始。
但請注意：Split 並不受Option Base 1影響，它的起始值還是以0開始。

請參考附件
[attach]23823[/attach]

作者: peter95 時間: 2016-4-12 22:38

回復 12# Kubi

好心人 Kubi 大大

小弟慚愧目前仍是小學生等級
所以還不能下載附件

請問有別的下載點嗎??

不好意思麻煩你了
再次感謝你的幫忙

作者: Kubi 時間: 2016-4-13 19:49

回復 13# peter95
請參考。
下載位址：http://www.FunP.Net/453186

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)