Board logo

標題: [發問] 請簡化錄製的程式碼。 [打印本頁]

作者: ziv976688    時間: 2019-5-21 05:40     標題: 請簡化錄製的程式碼。

測試檔 :[attach]30638[/attach]

以下是B2︰F2,G2︰K2,......, AU2︰AX2格式化條件公式錄製的程式碼︰
    Range("B2:F2").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(B2=MAX($B2:$F2))*(B2>0)"
    Selection.FormatConditions(1).Interior.ColorIndex = 43
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(SUMPRODUCT((B2<=$B2:$F2)/COUNTIF($B2:$F2,$B2:$F2))=2)*(B2>0)"
    Selection.FormatConditions(2).Interior.ColorIndex = 8
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(SUMPRODUCT((B2<=$B2:$F2)/COUNTIF($B2:$F2,$B2:$F2))=3)*(B2>0)"
    Selection.FormatConditions(3).Interior.ColorIndex = 37
   
    Range("G2:K2").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(G2=MAX($G2:$K2))*(G2>0)"
    Selection.FormatConditions(1).Interior.ColorIndex = 43
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(SUMPRODUCT((G2<=$G2:$K2)/COUNTIF($G2:$K2,$G2:$K2))=2)*(G2>0)"
    Selection.FormatConditions(2).Interior.ColorIndex = 8
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(SUMPRODUCT((G2<=$G2:$K2)/COUNTIF($G2:$K2,$G2:$K2))=3)*(G2>0)"
    Selection.FormatConditions(3).Interior.ColorIndex = 37


    Range("AU2:AX2").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(AU2=MAX($AU2:$AX2))*(AU2>0)"
    Selection.FormatConditions(1).Interior.ColorIndex = 43
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(SUMPRODUCT((AU2<=$AU2:$AX2)/COUNTIF($AU2:$AX2,$AU2:$AX2))=2)*(AU2>0)"
    Selection.FormatConditions(2).Interior.ColorIndex = 8
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(SUMPRODUCT((AU2<=$AU2:$AX2)/COUNTIF($AU2:$AX2,$AU2:$AX2))=3)*(AU2>0)"
    Selection.FormatConditions(3).Interior.ColorIndex = 37

共10段(請詳見測試檔)

請問︰可以再簡化嗎?

PS︰
公式要保留。
如果只能一段一段改,就請只改一段就可以了,其它9段我再套寫就好!

謝謝幫忙!
作者: Scott090    時間: 2019-5-21 11:43

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

回復 1# ziv976688

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

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

    以上供參 !謝謝你 !
作者: GBKEE    時間: 2019-5-21 16:50

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

回復 3# ziv976688

依你檔案的程式碼所簡化的迴圈
試試看
  1. Option Explicit
  2. Sub 格式化條件()
  3.     Dim Rng As Range, AR(1 To 3) As String,i As Integer
  4.     Set Rng = Range("B2:F2")     '第一個範圍
  5.     For i = 0 To 9                           '10範圍要處裡
  6.         With Rng
  7.             '**Rng.Address                  範圍的絕對位置 : $B2:$F2
  8.             '**Rng(1).Address(0, 0)     範圍的第一個Cell 相對位置 B2
  9.             ' *公式一"=(B2=MAX($B2:$F2))*(B2>0)"
  10.             AR(1) = "=(" & Rng(1).Address(0, 0) & "=MAX(" & Rng.Address & "))*(" & Rng(1).Address(0, 0) & ">0)"
  11.             '* 公式二"=(SUMPRODUCT((B2<=$B2:$F2)/COUNTIF($B2:$F2,$B2:$F2))=2)*(B2>0)"
  12.             AR(2) = "=(SUMPRODUCT((" & Rng(1).Address(0, 0) & "<=" & Rng.Address & ")/COUNTIF(" & Rng.Address & "," & Rng.Address & "))=2)*(" & Rng(1).Address(0, 0) & ">0)"
  13.             '* 公式三"=(SUMPRODUCT((B2<=$B2:$F2)/COUNTIF($B2:$F2,$B2:$F2))=3)*(B2>0)"
  14.             AR(3) = "=(SUMPRODUCT((" & Rng(1).Address(0, 0) & "<=" & Rng.Address & ")/COUNTIF(" & Rng.Address & "," & Rng.Address & "))=3)*(" & Rng(1).Address(0, 0) & ">0)"
  15.             .Select
  16.             .FormatConditions.Delete
  17.             .FormatConditions.Add Type:=xlExpression, Formula1:=AR(1)
  18.             .FormatConditions(1).Interior.ColorIndex = 43
  19.             .FormatConditions.Add Type:=xlExpression, Formula1:=AR(2)
  20.             .FormatConditions(2).Interior.ColorIndex = 8
  21.             .FormatConditions.Add Type:=xlExpression, Formula1:=AR(3)
  22.             .FormatConditions(3).Interior.ColorIndex = 37
  23.         End With
  24.         Set Rng = Rng.Offset(, Rng.Columns.Count)  '**下一個範圍
  25.     Next
  26. End Sub
複製代碼

作者: Scott090    時間: 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
作者: ziv976688    時間: 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;.......
所以無法再複製格式到其它列。
請問 : 要如何修改?

以上請你修正。謝謝你^^
作者: ziv976688    時間: 2019-5-21 19:56

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

回復 7# ziv976688

         抱歉,不知你是要保留用儲存格函數去執行的。
         請用 4# GBKEE 大大 提供的模式
作者: ziv976688    時間: 2019-5-22 00:35

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

回復 8# Scott090
不好意思,我在發問時,就有特別註明"公式要保留"~可能你沒有注意到
還是非常感謝你一再的幫忙
作者: ziv976688    時間: 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
所以無法再用"大掃把"複製格式到其它列。
請問 : 要如何修改?

以上  煩請你修正。謝謝你^^
作者: GBKEE    時間: 2019-5-22 07:34

回復 10# ziv976688
查看Vba說明  Address 屬性 ,自行試試修改


最後一段(第10段)$AU : $AX2  ->只有4欄
少一欄就減1
  1. Set Rng = Rng.Offset(, IIf(i < 9, Rng.Columns.Count, Rng.Columns.Count - 1))
複製代碼

作者: ziv976688    時間: 2019-5-22 15:47

回復 11# GBKEE

完成了!
感謝你的指教和幫忙
作者: ziv976688    時間: 2019-5-24 14:56

回復 11# GBKEE
[attach]30661[/attach]

列25          Set Rng = Rng.Offset(, IIf(i < 9, Rng.Columns.Count, Rng.Columns.Count - 1)) '**下一個範圍

不好意思,今天要使用,不知道為什麼還是多了一欄(AY2)^^"
可否請你再指正?謝謝你!
作者: GBKEE    時間: 2019-5-24 16:01

回復 13# ziv976688

請修正為
  1. Set Rng = Rng.Offset(, IIf(i < 8, Rng.Columns.Count, Rng.Columns.Count - 1)) '**下一個範圍
複製代碼

作者: ziv976688    時間: 2019-5-24 19:36

回復 14# GBKEE

Set Rng = Rng.Offset(, IIf(i < 9, Rng.Columns.Count, Rng.Columns.Count - 1))  '**下一個範圍

Set Rng = Rng.Offset(, IIf(i < 8, Rng.Columns.Count, Rng.Columns.Count - 1))  '**下一個範圍
二段成式碼都是計算到多1欄(AY欄);
以For i = 0 To 9 來說
應該是i < 9才是正確的
只是不知是甚麼原故,.Columns.Count - 1無效。
甚至改為.Columns.Count - 2還是計算到AY欄。
煩請再指正!謝謝你!
作者: GBKEE    時間: 2019-5-25 07:50

回復 15# ziv976688

對不起啦,沒認真看你的問題
應加上
  1. Set Rng = Rng.Offset(, Rng.Columns.Count) '**下一個範圍
  2.   If i = 8 Then Set Rng = Rng.Cells(1).Resize(, Rng.Columns.Count - 1)
複製代碼

作者: ziv976688    時間: 2019-5-25 14:05

本帖最後由 ziv976688 於 2019-5-25 14:15 編輯

回復 16# GBKEE

你太客氣了^^
不論過程,只論結果~有了最後正確的結果,我都是心存感激的。

再將絕對位址Rng.Address 改成絕對欄位址Rng.Address(0, 1)
完成了!
感謝你的耐心指導和幫忙




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