[發問] 請簡化錄製的程式碼。

帖子: 522
主題: 55
精華: 0
積分: 599
點名: 43
作業系統: win 10
軟體版本: []
閱讀權限: 50
性別: 男
註冊時間: 2013-3-19
最後登錄: 2025-2-20

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章 2015羊年全勤獎章

2^#

發表於 2019-5-21 11:43 | 只看該作者

本帖最後由 Scott090 於 2019-5-21 11:53 編輯

回復 1# ziv976688

請把條件用白話文謝看看
例如  Range("B2:F2") 中的
         條件 1. 最大數的底色是 ....
         條件 2. 次大 .... 底色是 ....
         條件 3. ........
         假如數字一樣大 ? ....
上面舉的不一定是這個問題的需求，只是試著用文字描述條件與結果需求
   有時用錄製的來改寫反而有些麻煩，當然有時錄製會有很大的助益。

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

3^#

發表於 2019-5-21 12:24 | 只看該作者

回復 2# Scott090
例如  Range("B2:F2") 中的
         條件 1. 最大數的底色是 ....43號底色
         條件 2. 次大 .... 底色是 ....8號底色
         條件 3. ........37號底色
         假如數字一樣大 ? ....同樣底色。EX :有二個或三個同是最大時，則都標示43號底色；有二個或三個同是次大時，則都標示8號底色；有二個或三個同是三大時，則都標示37號底色。

以上供參 !謝謝你 !

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2019-5-21 16:50 | 只看該作者

本帖最後由 GBKEE 於 2019-5-22 07:35 編輯

回復 3# ziv976688

依你檔案的程式碼所簡化的迴圈
試試看

Option Explicit
Sub 格式化條件()
Dim Rng As Range, AR(1 To 3) As String,i As Integer
Set Rng = Range("B2:F2") '第一個範圍
For i = 0 To 9 '10範圍要處裡
With Rng
'**Rng.Address 範圍的絕對位置 : $B2:$F2
'**Rng(1).Address(0, 0) 範圍的第一個Cell 相對位置 B2
' *公式一"=(B2=MAX($B2:$F2))*(B2>0)"
AR(1) = "=(" & Rng(1).Address(0, 0) & "=MAX(" & Rng.Address & "))*(" & Rng(1).Address(0, 0) & ">0)"
'* 公式二"=(SUMPRODUCT((B2<=$B2:$F2)/COUNTIF($B2:$F2,$B2:$F2))=2)*(B2>0)"
AR(2) = "=(SUMPRODUCT((" & Rng(1).Address(0, 0) & "<=" & Rng.Address & ")/COUNTIF(" & Rng.Address & "," & Rng.Address & "))=2)*(" & Rng(1).Address(0, 0) & ">0)"
'* 公式三"=(SUMPRODUCT((B2<=$B2:$F2)/COUNTIF($B2:$F2,$B2:$F2))=3)*(B2>0)"
AR(3) = "=(SUMPRODUCT((" & Rng(1).Address(0, 0) & "<=" & Rng.Address & ")/COUNTIF(" & Rng.Address & "," & Rng.Address & "))=3)*(" & Rng(1).Address(0, 0) & ">0)"
.Select
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=AR(1)
.FormatConditions(1).Interior.ColorIndex = 43
.FormatConditions.Add Type:=xlExpression, Formula1:=AR(2)
.FormatConditions(2).Interior.ColorIndex = 8
.FormatConditions.Add Type:=xlExpression, Formula1:=AR(3)
.FormatConditions(3).Interior.ColorIndex = 37
End With
Set Rng = Rng.Offset(, Rng.Columns.Count) '**下一個範圍
Next
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

Scott090

帖子: 522
主題: 55
精華: 0
積分: 599
點名: 43
作業系統: win 10
軟體版本: []
閱讀權限: 50
性別: 男
註冊時間: 2013-3-19
最後登錄: 2025-2-20

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章 2015羊年全勤獎章

5^#

發表於 2019-5-21 17:01 | 只看該作者

回復 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

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

6^#

發表於 2019-5-21 19:50 | 只看該作者

回復 4# GBKEE
感謝解答。
請再修正最後一段(第10段)$AU : $AX2 ->只有4欄
除了 For i = 0 To 9 改成= 0 To 8
請問 : 第9段要怎麼補寫?

還有直執行後的公式的"列位"多了絕對符號 " $ " ->EX : $B2 : $F2變成 $B$2 : $F$2 ；$G2 : $K2變成 $G$2 : $K$2；.......
所以無法再複製格式到其它列。
請問 : 要如何修改?

以上請你修正。謝謝你^^

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

7^#

發表於 2019-5-21 19:56 | 只看該作者

回復 5# Scott090
感謝解答。
執行後，前三大的(中式排名)底色標示正確，但公式不見了^^"
所以無法再作複製格式到其它列之用。
請你修正為能將公式保留。謝謝你^^

Scott090

帖子: 522
主題: 55
精華: 0
積分: 599
點名: 43
作業系統: win 10
軟體版本: []
閱讀權限: 50
性別: 男
註冊時間: 2013-3-19
最後登錄: 2025-2-20

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章 2015羊年全勤獎章

8^#

發表於 2019-5-21 22:16 | 只看該作者

回復 7# ziv976688

抱歉，不知你是要保留用儲存格函數去執行的。
請用 4# GBKEE 大大提供的模式

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

9^#

發表於 2019-5-22 00:35 | 只看該作者

本帖最後由 ziv976688 於 2019-5-22 00:36 編輯

回復 8# Scott090
不好意思，我在發問時，就有特別註明"公式要保留"~可能你沒有注意到

還是非常感謝你一再的幫忙

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

10^#

發表於 2019-5-22 07:12 | 只看該作者

本帖最後由 ziv976688 於 2019-5-22 07:23 編輯

回復 4# GBKEE
有筆誤~重新回覆和說明。

感謝解答。
請再修正最後一段(第10段)$AU2 : $AX2 ->只有4欄；不是$AU2 : AY2
除了 For i = 0 To 9 改成= 0 To 8
請問 : 第10段要怎麼補寫?

還有執行後的公式的"列位"多了絕對符號 " $ " ->EX : $B2 : $F2變成 $B$2 : $F$2 ；$G2 : $K2變成 $G$2 : $K$2；.......；$AP2 : $AT2變成$AP$2 : $AT$2；$AU2 : $AX2變成$AU$2 : $AX$2
所以無法再用"大掃把"複製格式到其它列。
請問 : 要如何修改?

以上煩請你修正。謝謝你^^