返回列表 上一主題 發帖

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

懇請各位大大幫忙編寫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

  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.   For lL1 = 1 To 4 ' 設定對角區域底色
  52.     Range(Cells(lRow(lL1), lCol(lL1)), Cells(lRow(lL1), lCol(lL1 + 1) - 1)) _
  53.          .Interior.ColorIndex = 36
  54.   Next
  55.   Range(Cells(lRow(5), lCol(5)), Cells(lRow(5), lCols)).Interior.ColorIndex = 36
  56.   
  57.   ReDim Preserve lCol(UBound(lCol) + 1) ' 縮減程式碼,這裡做個取巧動作,配合迴圈作業
  58.   lCol(UBound(lCol)) = lCols
  59.   
  60.   For lL1 = 1 To 5 ' 設定格式化公式
  61.     For lL2 = 1 To UBound(lRow)
  62.       For lL3 = 1 To 3
  63.         With Range(Cells(lRow(lL2), lCol(lL1)), Cells(lRow(lL2), lCol(lL1 + 1) - 1))
  64.           .FormatConditions.Add Type:=xlExpression, Formula1:= _
  65.           "=" & Cells(lRow(lL2), lCol(lL1)).Address(0, 0) & "=LARGE(" & .Offset(0).Address & "," & lL3 & ")"
  66.           .FormatConditions(.FormatConditions.Count).SetFirstPriority
  67.           With .FormatConditions(1).Interior
  68.             .PatternColorIndex = xlAutomatic
  69.             .ColorIndex = vColor(lL3)
  70.             .TintAndShade = 0
  71.           End With
  72.           .FormatConditions(1).StopIfTrue = True
  73.         End With
  74.       Next
  75.     Next
  76.   Next
  77. End Sub
複製代碼
格式化的語法-a.zip (29.78 KB)

TOP

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

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

        靜思自在 : 能幹不幹,不如苦幹實幹。
返回列表 上一主題