返回列表 上一主題 發帖

[發問] 不定區域段落的格式化語法。

本帖最後由 luhpro 於 2020-12-27 15:56 編輯
回復  luhpro
I 大 : 您好 !
感謝您的幫忙和指導
測試結果報告 :
大原則"自動分段"是OK的; ...
ziv976688 發表於 2020-12-26 16:26

晤...
Excel 2003 會有錯誤啊,
我有部分指令是透過Excel 2019 錄製巨集生再做修改的.
這裡先提供修改後支援多個五行資料的檔案, (因為不清楚你的資料是如何擴展的, 範例檔就直接把原表格左右上下拷貼增加了)
當然,應該還是會發生原先有的錯誤,
可支援2003版的檔案會晚一點,
Office不能同時裝兩套版本,
需要改去舊PC測一下.

另外,修改了一些小BUG,
還有,因為之前把舊格式全部刪掉了(包含總計),
所以再增加設定總計列格式的部分:
  1. Sub SetRng()
  2.   Dim vColor()
  3.   Dim lCol&(), lCols&, lRow&(), lRows&, lL1&, lL2&, lL3&, ll4&

  4.   vColor = Array(0, 38, 4, 8)
  5.   lL1 = 2 ' 取得五行所在欄號
  6.   lCols = Cells(lL1, Columns.Count).End(xlToLeft).Column ' 資料末欄
  7.   ReDim lCol(0) ' 陣列初始化
  8.   Do While lL1 <= lCols
  9.     ReDim Preserve lCol(UBound(lCol) + 1)
  10.     lCol(UBound(lCol)) = lL1
  11.     lL1 = Cells(1, lL1).End(xlToRight).Column  ' 找下個有資料的欄
  12.   Loop
  13.   
  14.   lL1 = 3 ' 取得小計與總計所在列號
  15.   ReDim lRow(0) ' 陣列初始化
  16.   Do While Cells(lL1, 1) <> "總計"
  17.     Do While Cells(lL1, 1) <> "小計" And Cells(lL1, 1) <> "總計"
  18.       lL1 = lL1 + 1
  19.     Loop
  20.     If Cells(lL1, 1) <> "總計" Then ' 小計所在列號
  21.       ReDim Preserve lRow(UBound(lRow) + 1)
  22.       lRow(UBound(lRow)) = lL1
  23.       lL1 = lL1 + 1
  24.     Else
  25.       lRows = lL1 ' 總計所在列號
  26.     End If
  27.   Loop
  28.   
  29.   ' ----- 清除格式設定與框線 -----
  30.   With Range(Cells(3, 2), Cells(lRows, lCols)) ' 資料範圍
  31.     .FormatConditions.Delete ' 清除所有格式規則
  32.     For lL1 = 1 To 10 ' 清除框線設定
  33.       .Borders(lL1).LineStyle = 0
  34.     Next
  35.     .Interior.Pattern = xlNone ' 清除底色
  36.   End With
  37.   
  38.   For lL1 = 2 To UBound(lCol) Step 2 ' 設定偶數段落
  39.     With Range(Cells(3, lCol(lL1)), Cells(lRows, lCol(lL1 + 1) - 1))
  40.       .Interior.ColorIndex = 34 ' 設定底色
  41.       For lL2 = 7 To 10 ' 設定外框線
  42.         With .Borders(lL2)
  43.           .LineStyle = 1
  44.           .ColorIndex = 5
  45.           .Weight = 4
  46.         End With
  47.       Next
  48.     End With
  49.   Next
  50.   
  51. On Error Resume Next ' 發生錯誤跳到下一行指令,例如超過陣列索引(最後一次時),列個數小於行個數
  52.   For lL1 = 1 To UBound(lCol) ' 設定對角區域底色
  53.     Range(Cells(lRow(lL1), lCol(lL1)), Cells(lRow(lL1), lCol(lL1 + 1) - 1)) _
  54.         .Interior.ColorIndex = 36
  55.   Next
  56.   lL1 = lL1 - 1
  57.   Range(Cells(lRow(lL1), lCol(lL1)), Cells(lRow(lL1), lCols)).Interior.ColorIndex = 36
  58. On Error GoTo 0 ' 發生錯誤中斷程式並顯示錯誤訊息
  59.   
  60.   ReDim Preserve lCol(UBound(lCol) + 1) ' 縮減程式碼,這裡做個取巧動作,配合迴圈作業
  61.   lCol(UBound(lCol)) = lCols
  62.   
  63.   ll4 = UBound(lCol) - 1 ' 減少計算次數
  64.   For lL1 = 1 To ll4 ' 小計列設定格式化公式
  65.     For lL2 = 1 To UBound(lRow)
  66.       For lL3 = 1 To 3
  67.         With Range(Cells(lRow(lL2), lCol(lL1)), Cells(lRow(lL2), _
  68.                      IIf(lL1 = ll4, lCols, lCol(lL1 + 1) - 1)))
  69.           .FormatConditions.Add Type:=xlExpression, Formula1:= _
  70.               "=" & Cells(lRow(lL2), lCol(lL1)).Address(0, 0) & _
  71.               "=LARGE(" & .Offset(0).Address & "," & lL3 & ")"
  72.           .FormatConditions(.FormatConditions.Count).SetFirstPriority
  73.           With .FormatConditions(1).Interior
  74.             .PatternColorIndex = xlAutomatic
  75.             .ColorIndex = vColor(lL3)
  76.             .TintAndShade = 0
  77.           End With
  78.           .FormatConditions(1).StopIfTrue = True
  79.         End With
  80.       Next
  81.     Next
  82.   Next
  83.   
  84.   For lL1 = 1 To ll4 ' 總計列設定格式化公式
  85.     If lL1 = ll4 Then
  86.       lL1 = lL1
  87.     End If
  88.     For lL3 = 1 To 3
  89.       With Range(Cells(lRows, lCol(lL1)), Cells(lRows, _
  90.                    IIf(lL1 = ll4, lCols, lCol(lL1 + 1) - 1)))
  91.         .FormatConditions.Add Type:=xlExpression, Formula1:= _
  92.             "=" & Cells(lRows, lCol(lL1)).Address(0, 0) & _
  93.             "=LARGE(" & .Offset(0).Address & "," & lL3 & ")"
  94.         .FormatConditions(.FormatConditions.Count).SetFirstPriority
  95.         With .FormatConditions(1).Interior
  96.           .PatternColorIndex = xlAutomatic
  97.           .ColorIndex = vColor(lL3)
  98.           .TintAndShade = 0
  99.         End With
  100.         .FormatConditions(1).StopIfTrue = True
  101.       End With
  102.     Next
  103.   Next
  104. End Sub
複製代碼
格式化的語法-a2.zip (74.96 KB)

TOP

回復  luhpro
I 大 : 您好 !
感謝您的幫忙和指導
測試結果報告 :
大原則"自動分段"是OK的; ...
ziv976688 發表於 2020-12-26 16:26

超過30分鐘.
剛剛發現當初為了安裝Office2019有把舊PC的Office移除了, (更糟糕的是Win7還不能安裝Office2109)
現在臨時找不到當初買的包裝序號. O.O
所以只能先以 n7822123大大 提供的程式片段來修改 :
      For lL3 = 1 To 3
        With Range(Cells(lRow(lL2), lCol(lL1)), Cells(lRow(lL2), _
                     IIf(lL1 = ll4, lCols, lCol(lL1 + 1) - 1)))
          .FormatConditions.Add Type:=xlExpression, Formula1:= _
              "=" & Cells(lRow(lL2), lCol(lL1)).Address(0, 0) & _
              "=LARGE(" & .Offset(0).Address & "," & lL3 & ")".Interior.ColorIndex = vColor(lL3) ' <--- 加這段
          '.FormatConditions(.FormatConditions.Count).SetFirstPriority ' 底下都刪掉
          'With .FormatConditions(1).Interior
          '  .PatternColorIndex = xlAutomatic
          '  .ColorIndex = vColor(lL3)
          '  .TintAndShade = 0
          'End With
          '.FormatConditions(1).StopIfTrue = True

        End With
      Next
沒環境不能驗證,
只好請你自己試試看了......

TOP

本帖最後由 ziv976688 於 2020-12-27 19:57 編輯

回復 11# luhpro
luhpro大大 : 您好 !
除了前3大標示底色因有與2003版衝突之外,其餘測試都OK了
2003版的部分,理應由小弟自己來測試,如再有問題,我會自行修改的。
真是辛苦您了!謝謝您的無比熱心幫忙和耐心指導~小弟獲益良多~感恩*n次

TOP

本帖最後由 luhpro 於 2020-12-27 22:07 編輯
回復  luhpro
luhpro大大 : 您好 !
除了前3大標示底色因有與2003版衝突之外,其餘測試都OK了
...
ziv976688 發表於 2020-12-27 19:48

抱歉,沒實測果然還是會出錯, 12#的程式有問題, 之前的程式在2003要修改一下:
          .FormatConditions.Add Type:=xlExpression, Formula1:= _
              "=" & Cells(lRow(lL2), lCol(lL1)).Address(0, 0) & _
              "=LARGE(" & .Offset(0).Address & "," & lL3 & ")"
          .FormatConditions(lL3)
.Interior.ColorIndex = vColor(lL3) ' <--- 加這個

另,經測試, 設定格式時要先 Select 好作用區塊, 否則公式會是錯誤的.
再加上格式設定中畫面會亂跳,
所以我也加了 ScreenUpdating 控制,
修改後程式如下:
  1. Application.ScreenUpdating = False
  2.   ll4 = UBound(lCol) - 1 ' 減少計算次數
  3.   For lL1 = 1 To ll4 ' 小計列設定格式化公式
  4.     For lL2 = 1 To UBound(lRow)
  5.       For lL3 = 1 To 3
  6.         With Range(Cells(lRow(lL2), lCol(lL1)), Cells(lRow(lL2), _
  7.                      IIf(lL1 = ll4, lCols, lCol(lL1 + 1) - 1)))
  8.           .Select
  9.           .FormatConditions.Add Type:=xlExpression, Formula1:= _
  10.               "=" & Cells(lRow(lL2), lCol(lL1)).Address(0, 0) & _
  11.               "=LARGE(" & .Offset(0).Address & "," & lL3 & ")"
  12.           .FormatConditions(lL3).Interior.ColorIndex = vColor(lL3)
  13.           'With .FormatConditions(1).Interior
  14.           '  .PatternColorIndex = xlAutomatic
  15.           '  .ColorIndex = vColor(lL3)
  16.           '  .TintAndShade = 0
  17.           'End With
  18.           '.FormatConditions(1).StopIfTrue = True
  19.         End With
  20.       Next
  21.     Next
  22.   Next
  23.   
  24.   For lL1 = 1 To ll4 ' 總計列設定格式化公式
  25.     If lL1 = ll4 Then
  26.       lL1 = lL1
  27.     End If
  28.     For lL3 = 1 To 3
  29.       With Range(Cells(lRows, lCol(lL1)), Cells(lRows, _
  30.                    IIf(lL1 = ll4, lCols, lCol(lL1 + 1) - 1)))
  31.         .Select
  32.         .FormatConditions.Add Type:=xlExpression, Formula1:= _
  33.             "=" & Cells(lRows, lCol(lL1)).Address(0, 0) & _
  34.             "=LARGE(" & .Offset(0).Address & "," & lL3 & ")"
  35.         .FormatConditions(lL3).Interior.ColorIndex = vColor(lL3)
  36.         'With .FormatConditions(1).Interior
  37.         '  .PatternColorIndex = xlAutomatic
  38.         '  .ColorIndex = vColor(lL3)
  39.         '  .TintAndShade = 0
  40.         'End With
  41.         '.FormatConditions(1).StopIfTrue = True
  42.       End With
  43.     Next
  44.   Next
  45. Application.ScreenUpdating = True
複製代碼
格式化的語法-a2-2003.zip (66.38 KB)

TOP

回復 14# luhpro
I大 : 早安!
前3大標示也OK了
萬分感謝您"鍥而不捨"的熱心幫忙和指導~感恩再感恩...............

TOP

本帖最後由 ziv976688 於 2020-12-31 00:41 編輯

回復 5# n7822123
未命名.png
2020-12-31 00:30

測試檔 :   格式化的語法-1231-五行測試-Q.rar (32.11 KB)
n大 : 您好!
不好意思
可否請您再幫忙寫1個有起始列(EX︰191列)和迄止列(EX︰199列)~因為這個部分每個排序的起迄列之位址不一定相同~
並能依據第1列的文字自動分段畫框線和標示34號底色及總計列之前3大各標示底色的VBA(EX︰設定格式B)?
因為我沒有辦法自己以設定格式A去修改
請詳見附件A191︰AX199
謝謝您

TOP

本帖最後由 ziv976688 於 2020-12-31 01:13 編輯

不好意思,測試檔模組1的Call 設定格B,請改為設定格式B
謝謝!

TOP

回復 17# ziv976688


改好了~也上了註解

格式化的語法-1231-五行測試-Q.rar (35.12 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 ziv976688 於 2020-12-31 03:46 編輯

回復 18# n7822123
n大 : 您好!
感謝您的註解,受益良多~~~
真是太厲害了,起迄列在哪裡都適用(含金彩539都可以用),我原先還自作聰明,將 [B3].Activate改為 [B191](現在有再改回[B3])~真拙
謝謝您的快速回覆和耐心指導~感恩(鞠躬)~~~~~

TOP

        靜思自在 : 修行要繫緣修心,藉事練心,隨處養心。
返回列表 上一主題