- 帖子
- 835
- 主題
- 6
- 精華
- 0
- 積分
- 915
- 點名
- 16
- 作業系統
- Win 10,7
- 軟體版本
- 2019,2013,2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2010-5-3
- 最後登錄
- 2024-11-14
|
11#
發表於 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,
還有,因為之前把舊格式全部刪掉了(包含總計),
所以再增加設定總計列格式的部分:- Sub SetRng()
- Dim vColor()
- Dim lCol&(), lCols&, lRow&(), lRows&, lL1&, lL2&, lL3&, ll4&
- vColor = Array(0, 38, 4, 8)
- lL1 = 2 ' 取得五行所在欄號
- lCols = Cells(lL1, Columns.Count).End(xlToLeft).Column ' 資料末欄
- ReDim lCol(0) ' 陣列初始化
- Do While lL1 <= lCols
- ReDim Preserve lCol(UBound(lCol) + 1)
- lCol(UBound(lCol)) = lL1
- lL1 = Cells(1, lL1).End(xlToRight).Column ' 找下個有資料的欄
- Loop
-
- lL1 = 3 ' 取得小計與總計所在列號
- ReDim lRow(0) ' 陣列初始化
- Do While Cells(lL1, 1) <> "總計"
- Do While Cells(lL1, 1) <> "小計" And Cells(lL1, 1) <> "總計"
- lL1 = lL1 + 1
- Loop
- If Cells(lL1, 1) <> "總計" Then ' 小計所在列號
- ReDim Preserve lRow(UBound(lRow) + 1)
- lRow(UBound(lRow)) = lL1
- lL1 = lL1 + 1
- Else
- lRows = lL1 ' 總計所在列號
- End If
- Loop
-
- ' ----- 清除格式設定與框線 -----
- With Range(Cells(3, 2), Cells(lRows, lCols)) ' 資料範圍
- .FormatConditions.Delete ' 清除所有格式規則
- For lL1 = 1 To 10 ' 清除框線設定
- .Borders(lL1).LineStyle = 0
- Next
- .Interior.Pattern = xlNone ' 清除底色
- End With
-
- For lL1 = 2 To UBound(lCol) Step 2 ' 設定偶數段落
- With Range(Cells(3, lCol(lL1)), Cells(lRows, lCol(lL1 + 1) - 1))
- .Interior.ColorIndex = 34 ' 設定底色
- For lL2 = 7 To 10 ' 設定外框線
- With .Borders(lL2)
- .LineStyle = 1
- .ColorIndex = 5
- .Weight = 4
- End With
- Next
- End With
- Next
-
- On Error Resume Next ' 發生錯誤跳到下一行指令,例如超過陣列索引(最後一次時),列個數小於行個數
- For lL1 = 1 To UBound(lCol) ' 設定對角區域底色
- Range(Cells(lRow(lL1), lCol(lL1)), Cells(lRow(lL1), lCol(lL1 + 1) - 1)) _
- .Interior.ColorIndex = 36
- Next
- lL1 = lL1 - 1
- Range(Cells(lRow(lL1), lCol(lL1)), Cells(lRow(lL1), lCols)).Interior.ColorIndex = 36
- On Error GoTo 0 ' 發生錯誤中斷程式並顯示錯誤訊息
-
- ReDim Preserve lCol(UBound(lCol) + 1) ' 縮減程式碼,這裡做個取巧動作,配合迴圈作業
- lCol(UBound(lCol)) = lCols
-
- ll4 = UBound(lCol) - 1 ' 減少計算次數
- For lL1 = 1 To ll4 ' 小計列設定格式化公式
- For lL2 = 1 To UBound(lRow)
- 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 & ")"
- .FormatConditions(.FormatConditions.Count).SetFirstPriority
- With .FormatConditions(1).Interior
- .PatternColorIndex = xlAutomatic
- .ColorIndex = vColor(lL3)
- .TintAndShade = 0
- End With
- .FormatConditions(1).StopIfTrue = True
- End With
- Next
- Next
- Next
-
- For lL1 = 1 To ll4 ' 總計列設定格式化公式
- If lL1 = ll4 Then
- lL1 = lL1
- End If
- For lL3 = 1 To 3
- With Range(Cells(lRows, lCol(lL1)), Cells(lRows, _
- IIf(lL1 = ll4, lCols, lCol(lL1 + 1) - 1)))
- .FormatConditions.Add Type:=xlExpression, Formula1:= _
- "=" & Cells(lRows, lCol(lL1)).Address(0, 0) & _
- "=LARGE(" & .Offset(0).Address & "," & 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
- Next
- End Sub
 格式化的語法-a2.zip (74.96 KB)
|
|
