VBA to Remove Conditional Formats, but Not the Results

RECOChris · Jan 16th 2020

Hello,

I have the following code (as a module) in Excel 2010 that creates a .xlsx static copy of 3 specific sheets of large macro-enabled workbook (that I can't share here) with a button click. The code also removes certain objects, all hyperlinks, converts all formulas to just values, removes all data validation, and breaks all external workbook links. The only other thing I want the code to do is to keep the effects of any conditional formatting but remove the conditions.

Code

''Creates a 3-sheet .xlsx static file removing all hyperlinks, formulas, and data validation
Option Explicit
Sub StaticReporter()
'Define variables
Dim wb As Workbook
Dim ws As Worksheet
Dim l As Long
Dim xOLE As Object
Dim ExternalLinks As Variant
Dim nm As Name
Dim shp As Shape
Dim fName
'Open Save As dialog box
fName = Application.GetSaveAsFilename(fileFilter:="Excel Workbook (*.xlsx), *.xlsx")
If fName = False Then
'MsgBox "Please enter a valid workbook name." <-- Undecided placeholder.
Exit Sub
Else
GoTo ReportStart
End If
ReportStart:
With Application
.ScreenUpdating = False
.DisplayAlerts = False
'Copy specific sheets
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy
'Paste sheets as values; remove hyperlinks, data validation, and formulas; and select A1 on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
ws.Cells.Validation.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
'Delete all command and toggle buttons
For Each xOLE In ActiveSheet.OLEObjects
If TypeName(xOLE.Object) = "CommandButton" Or TypeName(xOLE.Object) = "ToggleButton" Then
xOLE.Delete
End If
Next
'Delete all but specific images or text boxes
For Each shp In ActiveSheet.Shapes
If shp.Name <> "Shape1" And shp.Name <> "Shape2" And shp.Name <> "Shape3" And shp.Name <> "Shape4" Then
shp.Delete
End If
Next
Next ws
Cells(1, 1).Select
'Remove named ranges
On Error Resume Next
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
Set wb = ActiveWorkbook
'Create an array of any external links
ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
'Loop through each external link and break it
For l = 1 To UBound(ExternalLinks)
wb.BreakLink Name:=ExternalLinks(l), Type:=xlLinkTypeExcelLinks
Next l
Sheets("Sheet1").Activate
ActiveWindow.ScrollRow = 11
Range("A1").Select
ActiveWorkbook.SaveAs fName, FileFormat:=51, CreateBackup:=False
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

Display More

I've tried incorporating the following into different places of my code, but I can't seem to get anything to work.

Removing Conditional Formats, but Not the Effects (Microsoft Excel)

Running Allen Wyatt's code as an independent module seems to have the most promise, however, when I plug in a

Call PasteFC()

before the

Next ws

line of my code, I get an error 13 type mismatch in the last case (the Expression case) of the ActiveCondition function at line:

If Application.Evaluate(FC.Formula1) Then.

I've also tried the responses in:

vba - Excel - Copy Conditional Formatting, Remove Rules, Keep Format

and

Pasting Conditional Formatting

Since Wyatt Allen's code seems the closest to accomplishing what I'm after, is the error 13 the easiest to resolve? Or are there other, better venues?

Thanks in advance.

**Carim** · Jan 16th 2020

Hello,

Have you tested the following

Code

Sub Keep_Formats()
' Keep Formats while Deleting Conditional Formatting
Dim ws As Worksheet
Dim mySel As Range, aCell As Range
'~~> To be Adapted ''''''''''''''''''''
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> To be Adapted ''''''''''''''''''''
Set mySel = ws.Range("A1:A10")
For Each aCell In mySel
With aCell
.Font.FontStyle = .DisplayFormat.Font.FontStyle
.Interior.Color = .DisplayFormat.Interior.Color
.Font.Strikethrough = .DisplayFormat.Font.Strikethrough
End With
Next aCell
mySel.FormatConditions.Delete
End Sub

Display More

RECOChris · Jan 16th 2020

Thank you, Carim! This works fantastically with the single exception that it doesn't maintain any cell border conditioning, which I have a good amount of.

**Carim** · Jan 16th 2020

You are welcome

Will take a look at what is so specific about ' cell border conditioning ' ...

**Carim** · Jan 16th 2020

Re,

Hope Version 2 will be in line with your expectations ...

Code

Sub Keep_Formats2()
' Version 2
' Keep All Formats while Deleting Conditional Formatting
Dim ws As Worksheet
Dim mySel As Range, aCell As Range
'~~> To be Adapted ''''''''''''''''''''
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> To be Adapted ''''''''''''''''''''
Set mySel = ws.Range("A1:A10")
For Each aCell In mySel
With aCell
.Font.FontStyle = .DisplayFormat.Font.FontStyle
.Interior.Color = .DisplayFormat.Interior.Color
.Font.Strikethrough = .DisplayFormat.Font.Strikethrough
.BorderAround = .DisplayFormat.Borders
End With
Next aCell
mySel.FormatConditions.Delete
End Sub

Display More

RECOChris · Jan 16th 2020

Running into a Run-time error '424': Object required here:

.BorderAround = .DisplayFormat.Borders

**Carim** · Jan 16th 2020

Just discovered borders properties have to be managed individually ...

Since the number of potential combinations is quite enormous ... could you post a small sample file to illustrate the Borders you are actually using ...

RECOChris · Jan 16th 2020

Hi Carim,

*In my case* here is the border situation:

The cell (or merged cells) will have a thick box border by default; I do not have any conditional formatting that affects borders between cells. My conditional formatting (if the condition is met) will remove the left border, the top border, and the right border. *Sometimes* the bottom border will also be removed (if the condition is met), but more often than not, it will remain. I never change border color or style. I can put together a file if it will help, but it will have to wait until morning.

RECOChris · Jan 17th 2020

Here is my small sample file. Please let me know if you have any questions.

CF Styles.xlsx

**Carim** · Jan 17th 2020

Hello,

Thanks for the sample file.

But, to my surprise ... not a single Conditional Formatting rule ...

RECOChris · Jan 17th 2020

Apologies! That was just the visual, please see attached for CF rules included.

**Carim** · Jan 17th 2020

Thanks for your latest sample file

It will allow to perform some tests which will be customized to your specific situation ...

**Carim** · Jan 17th 2020

Let me quickly recap what must be actually tested for each cell :

1. the Numbers of Borders :

Only 3 possible cases : 4 Borders( always around), 1 (always Bottom) , 0 (none)

2. the Borders Line Style :

Only 1 possible case : Continuous

3. the Borders Weight :

Only 1 possible case : Thick

4. the Borders Color :

Only 1 possible case : Black

Thanks for confirming above characteristics ...

RECOChris · Jan 17th 2020

That's correct. Thank you!

**Carim** · Jan 18th 2020

Thanks a lot for your confirmation

Will now dive into the intricacies of ' Conditionally Formatted Cell Borders ' ...

**Carim** · Jan 18th 2020

Hi,

Attached is your Test file to deal your specifics regarding Conditional Formatting Borders ...

Hope we are heading in the right direction

RECOChris · Jan 20th 2020

Thank you for this, Carim! When I run the code, I hit a Run-time error '13': Type mismatch here:

If Len(c) >0 Then

**Carim** · Jan 20th 2020

Hello,

When you say ' run the code ' ....

Are you talking about the Test file ... or about your real-life worksheet ...?

RECOChris · Jan 20th 2020

I copy-pasted the code from the test file in your post into the code in my file and ran the sub:

Code

''Creates a 3-sheet .xlsx static file removing all hyperlinks, formulas, data validation, and conditional formatting rules while keeping conditional formatting results
Option Explicit
Sub EstimateReporter()
'Define variables
Dim wb As Workbook
Dim ws As Worksheet
Dim l As Long
Dim xOLE As Object
Dim ExternalLinks As Variant
Dim nm As Name
Dim shp As Shape
Dim Rng As Range, c As Range
Dim i As Integer, counter As Integer
Dim fName
'Open Save As dialog box
fName = Application.GetSaveAsFilename(fileFilter:="Excel Workbook (*.xlsx), *.xlsx")
If fName = False Then
'MsgBox "Please enter a valid workbook name." <-- Undecided placeholder
Exit Sub
Else
GoTo ReportStart
End If
ReportStart:
With Application
.ScreenUpdating = False
.DisplayAlerts = False
'Copy specific sheets
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy
'Paste sheets as values; remove hyperlinks, data validation, and formulas; and select A1 on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
ws.Cells.Validation.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
'Delete all command and toggle buttons
For Each xOLE In ActiveSheet.OLEObjects
If TypeName(xOLE.Object) = "CommandButton" Or TypeName(xOLE.Object) = "ToggleButton" Then
xOLE.Delete
End If
Next
'Delete all but specific images or text boxes
For Each shp In ActiveSheet.Shapes
If shp.Name <> "Shape1" And shp.Name <> "Shape2" And shp.Name <> "Shape3" And shp.Name <> "Shape4" Then
shp.Delete
End If
Next
Set Rng = ws.Range("A1:AC205")
For Each c In Rng
' Test cell length ... to avoid contiguous headache whenever a cell shows
' a bottom border which is, in fact ... the top border of the following cell
If Len(c) > 0 Then
With c
.Interior.Color = .DisplayFormat.Interior.Color
.Interior.Pattern = .DisplayFormat.Interior.Pattern
.Font.FontStyle = .DisplayFormat.Font.FontStyle
.Font.Background = .DisplayFormat.Font.Background
.Font.Strikethrough = .DisplayFormat.Font.Strikethrough
.Font.Bold = .DisplayFormat.Font.Bold
.Font.Color = .DisplayFormat.Font.Color
' Determine the number of Borders with counter
' 4 Borders: xlEdgeLeft = 7 / xlEdgeTop = 8 / xlEdgeBottom = 9 / xlEdgeRight = 10
counter = 0
If .DisplayFormat.Borders(7).LineStyle = xlContinuous Then
counter = 4
ElseIf .DisplayFormat.Borders(9).LineStyle = xlContinuous Then
counter = 1
Else
counter = 0
End If
' Deal with the 3 possible Borders situations
Select Case counter
' 0 Border means None
Case 0
.Borders.LineStyle = xlNone
' 1 Border means xlEdgeBottom
Case 1
.Borders(9).LineStyle = xlContinuous
.Borders(9).Weight = xlThick
.Borders(9).Color = RGB(0, 0, 0)
Case 4
' 4 Borders means All Borders Around
For i = 7 To 10
.Borders(i).LineStyle = xlContinuous
.Borders(i).Weight = xlThick
.Borders(i).Color = RGB(0, 0, 0)
Next i
End Select
End With
End If
Next c
' Delete Conditional Formatting Rules
Rng.FormatConditions.Delete
' For More Info :
' Source : https://software-solutions-online.com/excel-vba-get-border-properties/
Next ws
Cells(1, 1).Select
'Remove named ranges
On Error Resume Next
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
Set wb = ActiveWorkbook
'Create an array of any external links
ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
'Loop through each external link and break it
For l = 1 To UBound(ExternalLinks)
wb.BreakLink Name:=ExternalLinks(l), Type:=xlLinkTypeExcelLinks
Next l
Sheets("Sheet1").Activate
ActiveWindow.ScrollRow = 11
Range("A1").Select
ActiveWorkbook.SaveAs fName, FileFormat:=51, CreateBackup:=False
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

Display More

**Carim** · Jan 20th 2020

Re,

Just out of curiosity ... Have you tried to run the macro in the Test file attached in message # 16 ...?

Share