Copying Conditional Formatting from one cell to another

[Guest]

I'm trying to copy a large number of conditional formats from one set of
cells to another. I don't want to explicitly define the formatting in VBA,
but rather take it from an existing set of cells. Is there a way to do this
without parsing out all the various components of a given conditional format?

I tried the following, which failed miserably:

Dim intFormCondNum As Integer

' Loop over a set of Source/Destination cell pairs

With SourceCell

..Worksheet.Unprotect
DestCell.Worksheet.Unprotect

' ******** This part doesn't work**********
If DestCell.FormatConditions.Count > 0 Then
For intFormCondNum = 1 To DestCell.FormatConditions.Count
.FormatConditions(intFormCondNum) = _
DestCell.FormatConditions(intFormCondNum)
Next
End If
'***********************************

.Copy ' Copy formatted contents of SourceCell to the Clipboard

' Paste formatted contents of Clipboard to the DestCell
DestCell.PasteSpecial (xlPasteAllExceptBorders)

.Worksheet.Protect ' Protect the Source Cell worksheet
DestCell.Worksheet.Protect ' Protect the Destination Cell worksheet

End With ' SourceCell

As background, it may help to know that I'm copying source cells that have
rich text formatting, that I don't want to lose. Most of the formatting of
the end result should come from teh destination cell, but the text formatting
needs to come from the source. I've only just noticed that I've been
overwriting the destinations conditional formatting.

 

[Peter T]

I'm confused trying to relate what you describe with your pseudo code,
ambiguous. Not sure why you are copying formats after CF's (which will
remove CF's) rather than other way round, (not that you could do what you
are attempting to do).

One way to interpret what you are want would imply simply pastespecial
formats for both your 'rich text' and CF formats, but I take it that's not
what you want.

Anyway, looking only at the subject line, you would indeed need to parse out
the conditions & formats if you don't want to copy any other formats. Can be
done but relative formulas require particular attention, eg A$1 is partially
relative and can't simply be copied from a CF formula in one cell to another
without multiple conversions.

Do you want to copy a CF from a single source cell to a destination of
multiple cells, but not other formats. If so, all formulas in the source
CF's would need to be carefully prepared in terms of relative and absolute
such that all would work as expected if doing a manual pastespecial
formats..

Regards,
Peter T

 

[Guest]

Peter,

You commented:
"Not sure why you are copying formats after CF's (which will remove CF's)
rather than other way round, (not that you could do what you are attempting
to do)."

Notice that the inner loop in my code is intended to copy the CFs from the
Destination Cell to the Source Cell, then I copy the entire Source Cell to
the Destination Cell. In this way I wanted the end result to have the rich
text formatting of the source cell but the CFs from the Destimation cell.

It sounds like copying the CFs by themselves is not easy. I gave up.
Instead I have decided to split the destination cells into two groups: those
with conditional formats and those without. When a destination cell has CFs
I'm copying the source cell using PasteValues, when it does not have CFs I'm
copying the source cell using PasteAll. This is reasonable workaround for my
purposes, most of the time.

--Bill

 

[Peter T]

HI Bill,

The explanation of your code does make sense now!

It sounds like copying the CFs by themselves is not easy. I gave up.

If you still want to try copying purely the CF's, try the following (watch
out for line-wrap) -

Sub Test()
Dim rSource As Range
Dim rDest As Range

If ActiveCell Is Nothing Then Exit Sub
Set rSource = ActiveSheet.Range("B2")
Set rDest = ActiveSheet.Range("D210")

CopyCF rSource, rDest

End Sub

Sub CopyCF(rSource As Range, rDest As Range)
Dim vIntFmts(0 To 2), vFontFmts(0 To 7), vBdrFmts(1 To 4, 0 To 2)
Dim f1 As String, f2 As String
Dim nOp As Long, nType As Long
Dim fc As FormatCondition

' check rSource is a single cell and has FC
If rSource.Count > 1 Or _
rSource(1).FormatConditions.Count = 0 Then
Exit Sub
End If

rDest.FormatConditions.Delete
For Each fc In rSource.FormatConditions
Erase vIntFmts: f2 = ""
nType = fc.Type
If nType = 2 Then
nOp = 0
Else
nOp = fc.Operator
End If

f1 = Application.ConvertFormula(fc.Formula1, xlA1, xlR1C1)
f1 = Application.ConvertFormula(f1, xlR1C1, xlR1C1, , ActiveCell)

On Error Resume Next
f2 = fc.Formula2
If Len(f2) Then
f2 = Application.ConvertFormula(f2, xlA1, xlR1C1)
f2 = Application.ConvertFormula(f2, xlR1C1, xlR1C1, ,
ActiveCell)
End If
On Error GoTo 0

With fc.Interior
vIntFmts(0) = .ColorIndex
vIntFmts(1) = .Pattern
vIntFmts(2) = .PatternColorIndex
End With
With fc.Font
' trap any/all of following to vFontFmts if anticipated required
'Bold, Colorindex, Italic, Name, Size, StrikeThrough, Superscript, Underline
End With

With fc.Borders
'loop .Item(1) to .Item(4)
' trap any/all of following to vBdrFmts if necessary
' LineStyle, Weight, Colorindex
End With

With rDest.FormatConditions.Add(nType, nOp, f1, f2)

With .Interior
If Not IsNull(vIntFmts(0)) Then .ColorIndex = vIntFmts(0)
If Not IsNull(vIntFmts(1)) Then .Pattern = vIntFmts(1)
If Not IsNull(vIntFmts(2)) Then .PatternColorIndex = vIntFmts(2)
End With

' similarly apply Font & Border formats if trapped

End With
Next

End Sub

Include Font & Border formats if/as required.

As written, should be OK to copy CF in one cell to a block of cells BUT only
if the can do the same manually. AS mentioned before that means
relative/absolute addressing should be correct, which otherwise might not be
necessary.

The main difficulty above is getting those ConvertFormula's correct. In a
light test all seemed OK with a mixture of CF types & relative/absolute
addresses, but test thoroughly. I didn't test copying CF's NOT on the
activesheet, and anticipate a bit more work to cater for that if necessary.

Regards,
Peter T