Fragmented Conditional Formatting

[sparky2205]

Hi folks,
I have a worksheet which contains data referencing different batches. The worksheet is password protected.
I provide the user with a button to run a macro to add new columns (3 each time) to add new data for additional batches.
I have conditional formatting on each of the columns which fragments when I perform the copy of the columns.
This I expected. However, the manner of the fragmentation I didn't expect.
The VBA for the copy copies the last 3 columns in the worksheet, inserts them to the right of the existing last populated column then clears the data from the newly copied columns except for formulas. The result is a new set of 3 'blank' columns.
When I looked at the conditional formatting I expected that the fracturing would have resulted in new rules for the newly created columns.
However, the newly created columns have been integrated into the existing rules but the original last 3 columns have fragmented.
Does anyone have an explanation for this behaviour?
Also, I presume it's a forlorn hope that anyone might have a way to avoid the fragmentation? My research would suggest I have to live with it. Although I did manage to prevent it when using VBA to add rows in a different project.


Thanks, as always, for any help.

 

[6StringJazzer]

Here is an idea which I have not tested. If you provide your code and a complete description of the CF rules then I might be able to test it. It should work if you do not have other formatting applied to the cells that you need to carry along.

To add your new columns use copy/paste formulas, which will copy without adding the CF rules.

Then use code to extend the Applies To range for the CF rules.

 

[sparky2205]

Hi,
I have added my code below.
The conditional formatting does the following:
1st & 2nd columns: set font colour = red where value not between Range min and Range max.
3rd column: set font colour = pink where value < Range min
set font colour = blue where value > Range max

Sub Insert_Columns()
Dim sht As Worksheet
Dim LastColumn As Long
Dim LastColumnLetter As String
Dim FirstColumnLetter As String
Dim NewLastColumnLetter As String
Dim NewFirstColumnLetter As String
Application.ScreenUpdating = False
Set sht = ThisWorkbook.ActiveSheet
    ' Get the last populated column number
    LastColumn = sht.Cells(19, sht.Columns.Count).End(xlToLeft).Column
    ' Convert this to the column letter i.e. last column to copy
    LastColumnLetter = Split(Cells(1, LastColumn).Address, "$")(1)
    ' Get the column letter of the first column to copy
    FirstColumnLetter = Split(Cells(1, LastColumn - 2).Address, "$")(1)
    ' Get the column letter of the first new column
    NewFirstColumnLetter = Split(Cells(1, LastColumn + 1).Address, "$")(1)
    ' Get the column letter of the last new column
    NewLastColumnLetter = Split(Cells(1, LastColumn + 3).Address, "$")(1)
    ' Select the range to copy
    Columns(FirstColumnLetter & ":" & LastColumnLetter).Select
    ' Copy the range
    Selection.Copy
    'ActiveSheet.Unprotect Password:="Test"
    ' Copy the selected columns to the right of their current location
    Selection.Insert Shift:=xlToRight
    'ActiveSheet.Protect Password:="Test", UserInterFaceOnly:=True, AllowFiltering:="True", allowinsertcolumns:="True"
    ' Select the newly copied columns
    Columns(NewFirstColumnLetter & ":" & NewLastColumnLetter).Select
    ' Clear the contents of the newly copied columns except for formulas
    Selection.SpecialCells(xlConstants).ClearContents
    ' Unprotect the sheet
    ActiveSheet.Unprotect Password:="Test"
    ' Clear comments
    Selection.ClearComments
    ' Rerotect the sheet
    ActiveSheet.Protect Password:="Test", UserInterFaceOnly:=True, AllowFiltering:="True"
    ' Repopulate the column headers
    Cells(19, NewFirstColumnLetter).Value = "Individual"
    Cells(19, NewLastColumnLetter).Value = "Moving Ave"
    Cells(19, Split(Cells(1, LastColumn + 2).Address, "$")(1)).Value = "Good Results"
    Cells(6, NewFirstColumnLetter).Select

Application.ScreenUpdating = True
End Sub

 

[6StringJazzer]

I need to spend a little with this but a few quick thoughts:

You do not have to convert column numbers to letters. You can use the numbers. Columns(1:3) is the same as Columns("A:C").

You don't have to select a range and then work on Selection. You can work directly on the range.

    Columns(FirstColumnLetter & ":" & LastColumnLetter).Select
    ' Copy the range
    Selection.Copy

can be written as

    ' Copy the range
    Columns(FirstColumnLetter & ":" & LastColumnLetter).Copy

Range min and Range max

Not sure what you mean by this. What range?

 

[sparky2205]

Those tips will certainly tidy my code up a lot.
Range min and Range max are two cells that hold the values for those criteria.
I added this so you would know that the conditional formatting rules refer to cells rather than values.
Probably not too important in the greater scheme of things but I added it for completeness in the description of the CF rules.

I did progress this a bit myself yesterday.
I replaced the insert with copy and paste, as suggested, but this also copied the CF rules to the new columns.
Of course it's possible the method I used isn't the one you were referring to. Code posted below.

Range(FirstColumnLetter & ":" & LastColumnLetter).Copy Range(NewFirstColumnLetter & ":" & NewFirstColumnLetter)

So then I tried deleting the CF rules after the copy, which did work.
I am now trying to extend the existing CR rules to include the new columns. I'm looking at using 'Cells.FormatConditions(1).ModifyAppliesToRange Range("myRange")'.
The immediate problem I see is defining ("myRange") as this will need to be dynamic. I did try running it with a defined range to see the results but it didn't append the range to the existing rule. It added a new rule for the new range.
Is there a way to programatically get the value of 'AppliesToRange'? Each time a new set of 3 columns is added, i.e. each time the macro is run, AppliesToRange will need to extend to include the new columns.
Maybe I'm not understanding the ModifyAppliesToRange properly.