Board logo

標題: [發問] 不定區域段落的格式化語法。 [打印本頁]
作者: ziv976688    時間: 2020-12-25 07:31     標題: 不定區域段落的格式化語法。

本帖最後由 ziv976688 於 2020-12-25 07:35 編輯

懇請各位大大幫忙編寫1個能依"小計"和"總計"的標題自動判別段落區域範圍作格式設定的程式檔，
以利能以1款式的程式碼即可完成執行各種排序段落的格式需求。
謝謝 !

需求︰
A_指定區域標示粗框線和底色
1_請將偶數段落(以B欄段落起算)由A3到總計列(位址不定)各標示5號粗框線和34號底色。
2_請將對角區域的小計列段落標示36號底色。

B_指定區域的前3大值標示底色
1_請將各"小計"列和"總計"列的各區域段落之前3大值(可重複)各標示38,4,8號底色。

詳如範例檔︰[attach]32873[/attach]
[attach]32874[/attach]
作者: n7822123    時間: 2020-12-26 04:16

回復 1# ziv976688


有上註解，不過應該還是不太好懂

執行完VBA 可以按 "Ctrl + G" 查看格式化條件的設定內容

讓你方便快速查看，不用一個個點進去，以後你也好自己修改

檔案如下，試試看~

[attach]32877[/attach]
作者: n7822123    時間: 2020-12-26 04:51

回復 2# n7822123

修改一下防呆程式(有找到範圍才執行)，避免跳錯誤

[attach]32878[/attach]
作者: ziv976688    時間: 2020-12-26 08:23

回復 3# n7822123
n大 : 早安 !
測試成功~太棒了 ! 終於完成適用全部不同欄位區域段落格式檔案的需求。
尤其貴程式碼有加上註解，讓我更容易了解程式碼的意義，有利於日後萬一有需求變更，可自行修改~
謝謝您的熱心幫忙和指導~感恩喔
作者: n7822123    時間: 2020-12-26 12:22

回復 4# ziv976688


寫的比較匆忙，有地方沒改到，請修改以下程式

公式1 = "=(" & 第一格 & "=MAX(" & 公式範圍 & "))*(B11>=0)"

改為

公式1 = "=(" & 第一格 & "=MAX(" & 公式範圍 & "))*(" & 第一格 & ">=0)"

這樣才完全符合你原本的範例公式
作者: luhpro    時間: 2020-12-26 15:15

懇請各位大大幫忙編寫1個能依"小計"和"總計"的標題自動判別段落區域範圍作格式設定的程式檔，
以利能以1款 ...
ziv976688 發表於 2020-12-25 07:31

提供另外一個角度的寫法 :
  1. Sub SetRng()
  2.   Dim vColor()
  3.   Dim lCol&(), lCols&, lRow&(), lRows&, lL1&, lL2&, lL3&
  4.   
  5.   ReDim lCol(5) ' 五行只有5個
  6.   vColor = Array(0, 38, 4, 8)
  7.   ' ----- 取得所有關鍵欄號與列號 -----
  8.   lCol(1) = 2 ' 取得五行文字所在欄號
  9.   For lL1 = 2 To 5
  10.     lCol(lL1) = Cells(1, lCol(lL1 - 1) + 1).End(xlToRight).Column
  11.   Next
  12.   lCols = Cells(2, Columns.Count).End(xlToLeft).Column ' 在第2列找資料末欄
  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

  38.     ' ----- 開始格式設定 -----
  39.   For lL1 = 2 To UBound(lCol) Step 2 ' 設定偶數段落
  40.     With Range(Cells(3, lCol(lL1)), Cells(lRows, lCol(lL1 + 1) - 1))
  41.       .Interior.ColorIndex = 34 ' 設定底色
  42.       For lL2 = 7 To 10 ' 設定外框線
  43.         With .Borders(lL2)
  44.           .LineStyle = 1
  45.           .ColorIndex = 5
  46.           .Weight = 4
  47.         End With
  48.       Next
  49.     End With
  50.   Next
  51.   
  52.   For lL1 = 1 To 4 ' 設定對角區域底色
  53.     Range(Cells(lRow(lL1), lCol(lL1)), Cells(lRow(lL1), lCol(lL1 + 1) - 1)) _
  54.          .Interior.ColorIndex = 36
  55.   Next
  56.   Range(Cells(lRow(5), lCol(5)), Cells(lRow(5), lCols)).Interior.ColorIndex = 36
  57.   
  58.   ReDim Preserve lCol(UBound(lCol) + 1) ' 縮減程式碼,這裡做個取巧動作,配合迴圈作業
  59.   lCol(UBound(lCol)) = lCols
  60.   
  61.   For lL1 = 1 To 5 ' 設定格式化公式
  62.     For lL2 = 1 To UBound(lRow)
  63.       For lL3 = 1 To 3
  64.         With Range(Cells(lRow(lL2), lCol(lL1)), Cells(lRow(lL2), lCol(lL1 + 1) - 1))
  65.           .FormatConditions.Add Type:=xlExpression, Formula1:= _
  66.           "=" & Cells(lRow(lL2), lCol(lL1)).Address(0, 0) & "=LARGE(" & .Offset(0).Address & "," & lL3 & ")"
  67.           .FormatConditions(.FormatConditions.Count).SetFirstPriority
  68.           With .FormatConditions(1).Interior
  69.             .PatternColorIndex = xlAutomatic
  70.             .ColorIndex = vColor(lL3)
  71.             .TintAndShade = 0
  72.           End With
  73.           .FormatConditions(1).StopIfTrue = True
  74.         End With
  75.       Next
  76.     Next
  77.   Next
  78. End Sub
複製代碼
[attach]32879[/attach]
作者: ziv976688    時間: 2020-12-26 15:46

回復 5# n7822123
n大 :
有測試生肖的規格格式，3樓的答案也是正確的
謝謝您耐心的再作更精準的修正。
已依照貴見修改好了~感激不盡
[attach]32880[/attach]
[attach]32881[/attach]
作者: ziv976688    時間: 2020-12-26 16:26

本帖最後由 ziv976688 於 2020-12-26 16:43 編輯

回復 6# luhpro
I 大 : 您好 !
感謝您的幫忙和指導
測試結果報告 :
大原則"自動分段"是OK的；
只是有些"非爾因素"影響到正確的答案~
1_前3大的底色標示無法顯示~跳出錯誤438(物件不支援此屬性或方法)。
不好意思，可能是因受到我的Excel為2003版所致。
2_分隔段落只限於5個。
不好意思，因為我的文字說明只以一句"自動判別段落區域範圍"帶過，並沒有特別註明有很多種的段落區域，以致讓您誤會只有5段的一種區域範圍~尚請您見諒

PS：　
我是有買２０１６版的Ｅｘｃｅｌ，但將２００３版改成２０１６版，常會產生偵錯或甚至無法開啟檔案；　
因為經年累積的檔案甚多，無法一一修改，只好以２００３版續用 ，請您見諒，謝謝您！

[attach]32882[/attach]
[attach]32883[/attach]
作者: n7822123    時間: 2020-12-26 17:25

回復 7# ziv976688


    如果你的資料格式變化再大一點，第一格就不一定是B11了，修正後程式彈性會好一點
作者: ziv976688    時間: 2020-12-26 21:07

回復 9# n7822123
n大 :您好!.
哈~您誤解我的意思了~
我是說 : 如果您不提，我根本不知道3樓的貴解尚有可精進的地方
再次謝謝您的熱心指導和幫忙
作者: luhpro    時間: 2020-12-27 15:52

本帖最後由 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&

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

回復  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
沒環境不能驗證,
只好請你自己試試看了......
作者: ziv976688    時間: 2020-12-27 19:48

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

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

本帖最後由 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
複製代碼
[attach]32894[/attach]
作者: ziv976688    時間: 2020-12-28 07:48

回復 14# luhpro
I大 : 早安!
前3大標示也OK了
萬分感謝您"鍥而不捨"的熱心幫忙和指導~感恩再感恩...............
作者: ziv976688    時間: 2020-12-31 00:36

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

回復 5# n7822123
[attach]32917[/attach]
測試檔 :  [attach]32918[/attach]
n大 : 您好!
不好意思
可否請您再幫忙寫1個有起始列(EX︰191列)和迄止列(EX︰199列)~因為這個部分每個排序的起迄列之位址不一定相同~
並能依據第1列的文字自動分段畫框線和標示34號底色及總計列之前3大各標示底色的VBA(EX︰設定格式B)?
因為我沒有辦法自己以設定格式A去修改
請詳見附件A191︰AX199
謝謝您
作者: ziv976688    時間: 2020-12-31 01:09

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

不好意思，測試檔模組1的Call 設定格B，請改為設定格式B
謝謝!
作者: n7822123    時間: 2020-12-31 01:51

回復 17# ziv976688


改好了~也上了註解

[attach]32919[/attach]
作者: ziv976688    時間: 2020-12-31 03:35

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

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



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