- 帖子
- 533
- 主題
- 58
- 精華
- 0
- 積分
- 613
- 點名
- 261
- 作業系統
- win 10
- 軟體版本
- []
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-3-19
- 最後登錄
- 2026-11-1
             
|
回復 3# ziv976688
是這樣嗎?
Option Explicit
Option Base 1
Sub Main_test()
Dim sh As Worksheet
Dim i%, j%, k%, colNo%, RowNo%
Dim arWk%(5, 2), arColor()
Set sh = Sheets("sheet1")
'先還原底色
sh.Range([B2], Cells(2, 50)).Interior.ColorIndex = 0
arColor = Array(43, 8, 37)
colNo = [B2].End(xlToRight).Column
For i = 2 To colNo Step 5
For j = 1 To 5
arWk(j, 1) = Cells(2, j + i - 1): arWk(j, 2) = i + j - 1
Next
BubbleSortDesc arWk
k = 1
For j = 1 To 5
ColoringAgain:
If Val(arWk(j, 1)) <> 0 Then
Cells(2, arWk(j, 2)).Interior.ColorIndex = arColor(k)
If j + 1 > 5 Then Exit For
If arWk(j + 1, 1) = arWk(j, 1) Then j = j + 1: GoTo ColoringAgain
k = k + 1
End If
If k > 3 Then Exit For
Next
ReDim aewk(5, 2)
Next
End Sub
' 陣列排序由大而小
'======================
Sub BubbleSortDesc(arr)
Dim arTemp%(2)
Dim i%, j%, UB%
UB = UBound(arr)
For i = 1 To UB
For j = i + 1 To UB
If arr(i, 1) < arr(j, 1) Then
arTemp(1) = arr(i, 1): arTemp(2) = arr(i, 2)
arr(i, 1) = arr(j, 1): arr(i, 2) = arr(j, 2)
arr(j, 1) = arTemp(1): arr(j, 2) = arTemp(2)
End If
Next j
Next i
End Sub
Sub 格式化條件()
Main_test
End Sub |
|
發表於 2019-5-21 11:43
| 
