清潔條件格式（Excel VBA）

Question

如果已經得到回答，但我無法找到它，我表示歉意。這是我想要的：我們都知道刪除範圍，行和列將會拆分條件格式並使其變得醜陋。我想創建一個個人宏：

1.) Searches through all existing Conditional Formatting in the active sheet 
2.) Recognizes duplicates based on their condition and format result 
3.) Finds the leftmost column and highest row in all duplicates 
4.) Finds the rightmost column and lowest row in all duplicates 
5.) Determines a broadened Range using those four values 
6.) Remembers the condition and format 
7.) Deletes all duplicates 
8.) Recreates the Conditional Format over the broadened Range 
9.) Repeats until no more duplicates are found 
10) Outputs how many duplicates were deleted in a MsgBox 

我50％確信我會這樣做我自己，但我有一種感覺，我需要學習如何與數組變量工作。 （其中我完全無知，因此感到害怕）所以如果有人已經創建了這個，那麼我乞求你分享你的天才。或者如果有人認爲他們可以鞭打這一點，我爲你提供了創建可能成爲其中一個的機會個人宏觀用戶的整個人口中最常用的工具（右上角用Ctrl + Shift + V） 。

或者如果沒有人或想要，那麼也許一些提示？來吧，在這裏扔一塊骨頭！

Answer 1

此刪除重複的組複製和粘貼行時創建條件格式規則：

Option Explicit 

Public Sub resetConditionalFormatting() 

    Const F_ROW As Long = 2 
    Dim ws As Worksheet, ur As Range, maxCol As Long, maxRow As Long, thisCol As Long 
    Dim colRng As Range, fcCol As Range, fcCount As Long, fcAdr As String 

    Set ws = ThisWorkbook.ActiveSheet 
    Set ur = ws.UsedRange 
    maxRow = ur.Rows.Count 
    maxCol = ur.Columns.Count 

    Application.ScreenUpdating = False 
    For Each colRng In ws.Columns 
     If colRng.Column > maxCol Then Exit For 
     thisCol = thisCol + 1 
     Set fcCol = ws.Range(ws.Cells(F_ROW, thisCol), ws.Cells(maxRow, thisCol)) 
     With colRng.FormatConditions 
      If .Count > 0 Then 
       fcCount = 1 
       fcAdr = .Item(fcCount).AppliesTo.Address 

       While fcCount <= .Count 
        If .Item(fcCount).AppliesTo.Address = fcAdr Then 
         .Item(fcCount).ModifyAppliesToRange fcCol 
         fcCount = fcCount + 1 
        Else 
         .Item(fcCount).Delete 
        End If 
       Wend 

      End If 
     End With 
    Next 
    Application.ScreenUpdating = True 
End Sub 

。

在高級別：

• 它穿過活性片
• 確定基於組地址

• 的重複的使用範圍中的每一列如果它發現多組：

  • 對於第一組 - 它將AppliesTo範圍更新爲（firstRow：lastRow）
  • 刪除所有其他組

（可在.Delete語句後添加一個重複計數器）

---

測試文件

初始規則：

複製和粘貼的最後2行，兩次後：

---

注：：

清理後

• 有14種不同類型的規則和許多屬性a重新不​​同
• 並非所有類型都有.Formula或。一級方程式，甚至相同的格式屬性
• 類型可以在測試文件中看到或this Microsoft page

Answer 2

這是一個不完整的企圖，使其儘可能地通用

（爲起點僅提供）

Option Explicit 

Private Const SP As String = "||" 'string delimiter, or SeParator 

Public Sub x() 
    resetConditionalFormatting Sheet1.UsedRange 
End Sub 

---

Public Sub resetConditionalFormatting(Optional ByRef rng As Range = Nothing) 
    Const FIRST_ROW As Long = 2 

    Dim colRng As Range, thisCol As Long, fc As FormatCondition, thisFC As Long 
    Dim maxCell As Range, ws As Worksheet, cell1 As Range, cell2 As Range 

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange 
    Set ws = rng.Parent 
    Set maxCell = GetMaxCell(rng) 

    If maxCell.Row > 1 Or maxCell.Column > 1 Or Len(maxCell) > 0 Then 
     thisCol = 1 
     Set cell1 = ws.Cells(FIRST_ROW, thisCol) 
     Set cell2 = ws.Cells(maxCell.Row, thisCol) 
     For Each colRng In rng.Columns 
      thisFC = 1 
      For Each fc In colRng.FormatConditions 
       fc.ModifyAppliesToRange ws.Range(cell1, cell2) 
       thisFC = thisFC + 1 
      Next 
      thisCol = thisCol + 1 
     Next 
    End If 
End Sub 

---

Private Sub fcDupe(ByRef fc As Variant, ByRef fcType() As String, ByRef dupes As Long) 
    Dim tStr As String, itm As Variant, fcT As Byte 

    On Error Resume Next 'some properties may not be defined at runtime 
    With fc 

     fcT = .Type 

    tStr = SP 
    'Border, Font, and Interior apply to 1, 2, 5, 8, 9, 10, 11, 12, 13, 16, 17 
    tStr = tStr & CStr(ObjPtr(.Borders)) & _ 
        CStr(ObjPtr(.Font)) & _ 
        CStr(ObjPtr(.Interior)) 
    'CStr(ObjPtr(fc)): https://support2.microsoft.com/default.aspx?scid=kb;en-us;199824 

     Select Case fcT 
      Case xlCellValue    '1 
       tStr = tStr & .DateOperator 
       tStr = tStr & .Formula1 
       tStr = tStr & .Formula2 
       tStr = tStr & .Operator 
       tStr = tStr & .ScopeType 
       tStr = tStr & .Text 
       tStr = tStr & .TextOperator 
       tStr = tStr & SP 
      Case xlColorScale    '3 
       tStr = SP & CStr(ObjPtr(.ColorScaleCriteria)) 
       tStr = tStr & .Formula 
       tStr = tStr & .ScopeType 
       tStr = tStr & SP 
      Case xlDatabar     '4 
       tStr = SP & CStr(ObjPtr(.AxisColor)) & _ 
          CStr(ObjPtr(.BarBorder)) & _ 
          CStr(ObjPtr(.BarColor)) & _ 
          CStr(ObjPtr(.MaxPoint)) & _ 
          CStr(ObjPtr(.MinPoint)) & _ 
          CStr(ObjPtr(.NegativeBarFormat)) 
       tStr = tStr & .AxisPosition 
       tStr = tStr & .BarFillType 
       tStr = tStr & .Direction 
       tStr = tStr & .Formula 
       tStr = tStr & .PercentMax 
       tStr = tStr & .PercentMin 
       tStr = tStr & .ScopeType 
       tStr = tStr & .ShowValue 
       tStr = tStr & SP 
      Case xlTop10     '5 
       tStr = tStr & .CalcFor 
       tStr = tStr & .Percent 
       tStr = tStr & .Rank 
       tStr = tStr & .TopBottom 
       tStr = tStr & .ScopeType 
       tStr = tStr & SP 
      Case 6       'XlFormatConditionType.xlIconSet 
       tStr = SP & CStr(ObjPtr(.IconCriteria)) & CStr(ObjPtr(.IconSet)) 
       tStr = tStr & .Formula 
       tStr = tStr & .PercentValue 
       tStr = tStr & .ReverseOrder 
       tStr = tStr & .ScopeType 
       tStr = tStr & .ShowIconOnly 
       tStr = tStr & SP 
      Case xlUniqueValues    '8 
       tStr = tStr & .DupeUnique 
       tStr = tStr & .ScopeType 
       tStr = tStr & SP 
      Case xlTextString    '9 
       tStr = tStr & .DateOperator 
       tStr = tStr & .Formula1 
       tStr = tStr & .Formula2 
       tStr = tStr & .Operator 
       tStr = tStr & .ScopeType 
       tStr = tStr & .Text 
       tStr = tStr & .TextOperator 
       tStr = tStr & SP 
      Case xlAboveAverageCondition '12 
       tStr = tStr & .AboveBelow 
       tStr = tStr & .CalcFor 
       tStr = tStr & .Formula1 
       tStr = tStr & .Formula2 
       tStr = tStr & .NumStdDev 
       tStr = tStr & SP 
      Case xlExpression, _ 
       xlBlanksCondition, _ 
       xlTimePeriod, _ 
       xlNoBlanksCondition, _ 
       xlErrorsCondition, _ 
       xlNoErrorsCondition 
        tStr = tStr & .Formula1 
        tStr = tStr & .Formula2 
        tStr = tStr & SP 
     End Select 
     If InStr(1, fcType(fcT), tStr, vbBinaryCompare) = 0 Then 
      fcType(fcT) = fcType(fcT) & tStr 
     Else 
      .Delete 
      dupes = dupes + 1 
     End If 
    End With 
End Sub 

---

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range 

    'It returns the last cell of range with data, or A1 if Worksheet is empty 

    Const NONEMPTY As String = "*" 
    Dim lRow As Range, lCol As Range 

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange 

    If WorksheetFunction.CountA(rng) = 0 Then 
     Set GetMaxCell = rng.Parent.Cells(1, 1) 
    Else 
     With rng 
      Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ 
            After:=.Cells(1, 1), _ 
            SearchDirection:=xlPrevious, _ 
            SearchOrder:=xlByRows) 
      Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ 
            After:=.Cells(1, 1), _ 
            SearchDirection:=xlPrevious, _ 
            SearchOrder:=xlByColumns) 
      Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column) 
     End With 
    End If 
End Function 

的一種方式，以查看特定格式條件的所有特性：