Retrieving/Resetting Conditional Formatting on a Sheet

[TishyMouse]

I have a worksheet with multiple conditional formatting conditions set up on it. These are typically set on whole column ranges e.g. $A:$A or $A:$Z etc.


There is a table on the sheet and a macro I use to enable users to insert 1 or more rows in the table in a controlled fashion (using the subroutine below). Note that the user can choose to copy all of the content from the currently selected row or just copy the formulae.


The problem is that when I insert rows in this way I 'break up' the conditional formatting to instead of one condition for range $A:$A I get multiple conditions applied to ranges "=$A$1:$A$7,$A$9:$A$1048576" and "=$A$8" etc. As you can imagine, over time this gets extremely messy.


Note that if I turn off the protection on the sheet and just use 'tab' to manually add rows to the end of the table I don't see this problem, but I can't allow users to do this as it would interfere with the integrity of the data checking/formulae within the table.


So... I'd like to find a way either of inserting a row in a table that retains the original contiguous ranges for conditional formatting or a way to read and store the conditional formatting before inserting a row so that I can reinstate it afterwards. I have failed at both so would welcome any pointers. It doesn't seem possible, for example to retrieve the range associated with a conditional formatting condition, just the other way round i.e. get the conditional formatting associated with a range.




I guess a possible way round would be to manually enter and store the formatting rules in a separate area of the spreadsheet and delete/reapply them when adding new table rows but if I have to do this, it would be very handy to be able to get Excel to do the donkey work for me and print them out somewhere.

Thanks in advance

TM

Function InsertDuplicateRow(Optional intRowCount As Integer, Optional bolRemoveValues As Boolean) As Boolean


    Dim lngRow As Long
    Dim lngCurrRow As Long
    Dim lngTableFirstrow As Long
    Dim lstTable As ListObject
    
    Dim bolResponse As Boolean
    Dim c As Range
    Dim I As Integer
    Dim f As Filter


    
    Dim strEnteredValue As String
    
    InsertDuplicateRow = False
    
    
    Call EventsDisable
    On Error GoTo err_handler
    
    'Check for a non-continuous selection
    If Selection.Rows.Count <> 1 Then
        bolResponse = MsgBox("Please select one or more cells from a single row", vbOKOnly)
        Exit Function
    End If
    
    'Find out number of rows to insert (show dialog box)
    ' start up the form
    If intRowCount = 0 Then
        strEnteredValue = FEnterValue.GetValue("Enter number rows to add (append a B to enter blank rows)", "^[0-9]{0,3}[B]{0,1}$", "1", "Invalid entry. Please enter a number from 0 to 999 followed by 'B' or nothing")
        
        If Right(strEnteredValue, 1) = "B" Then
            intRowCount = Val(Mid(strEnteredValue, 1, Len(strEnteredValue) - 1))
            bolRemoveValues = True
        Else
            intRowCount = Val(strEnteredValue)
        End If
    End If
       
    If intRowCount > 0 Then
        Call UnprotectSheet
        
        'Remove filter if necessary
        If Not ActiveSheet.AutoFilter Is Nothing Then
            For Each f In ActiveSheet.AutoFilter.Filters
                If f.On Then
                    ActiveSheet.ShowAllData
                    Exit For
                End If
            Next
        End If
        
        lngRow = Selection.Row
        
        'If this is a table, check we aren't on the first row
        If Not Selection.ListObject Is Nothing Then
            Set lstTable = Selection.ListObject
            If lngRow >= lstTable.Range.Cells(lstTable.Range.Rows.Count, 1).Row Then
                If MsgBox("Can't append to the last line of the table, please select a different cell.", vbOKOnly) = vbOK Then
                    GoTo exit_sub
                End If
            End If
        End If




        'Use different insert method depending if we are in a table but NOT on the mappings sheet (where it is too slow)
        If Not lstTable Is Nothing And ActiveSheet.Name <> "Mappings" Then
            'Store the row number for the first row of the table
            lngTableFirstrow = lstTable.Range.Cells(1, 1).Row
            
            lstTable.ListRows(lngRow - lngTableFirstrow).Range.Copy
            For I = 1 To intRowCount
                'Insert the new cell into the row beneath the current row
                lstTable.ListRows.Add Position:=(I + lngRow - lngTableFirstrow)
            Next I
            'And if required copy the contents down...
            If Not bolRemoveValues Then
                lstTable.ListRows(Selection.Row - lngTableFirstrow).Range.Copy
                For I = 1 To intRowCount
                    lstTable.ListRows(I + lngRow - lngTableFirstrow).Range.PasteSpecial xlPasteValues
                Next I
            End If


            
        Else
            Range(Rows(lngRow + 1), Rows(lngRow + intRowCount)).Insert Shift:=xlDown
        
            Rows(lngRow).Copy
            For lngCurrRow = lngRow + 1 To lngRow + intRowCount
                Rows(lngCurrRow).Select
                ActiveSheet.Paste
                If bolRemoveValues Then
                    Dim endcell As Range
                    
                    'For Each c In Range(Cells(lngCurrRow, 1), Cells(lngCurrRow, ActiveSheet.Columns.Count))
                    For Each c In Range(Cells(lngCurrRow, 1), Cells(lngCurrRow, Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column))
                        If Not c.HasFormula Then
                            c.Value = ""
                        End If
                    Next
                End If
            Next
            Application.CutCopyMode = False
        End If
    
    End If
    InsertDuplicateRow = True


exit_sub:


    Call ProtectSheet
    Call EventsRestore


    Exit Function


err_handler:


    Call GlobalErrHandler(Err)


    
End Function