Pasting Conditional Formatting - excel

Question

I'm trying to copy the values and conditional formatting from a column in the sheet wsHR and paste them into wsHH.
With the code below the values are pasted, but the formatting is not.
I added formatting into wsHR that isn't conditional, and it works fine copying that over.
Is there a way to paste conditional formatting?
Private Sub CommandButton1_Click()
'Set variables
Dim LastRow As Long
Dim wsHR As Worksheet
Dim wsHH As Worksheet
Dim y As Integer
'Set row value
y = 4
'Set heavy chain raw data worksheet
Set wsHR = ThisWorkbook.Worksheets(4)
'Set heavy chain hits worksheet
Set wsHH = ThisWorkbook.Worksheets(6)
'Optimizes Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Finds last row
With wsHR
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Iterates through rows in column A, and copies the row into proper sheet depending on "X" in PBS/KREBS
For i = 4 To LastRow
'Checks for "X" in PBS
If VarType(wsHR.Range("AD" & i)) = 8 Then
If wsHR.Range("AD" & i).Value = "X" Or wsHR.Range("AE" & i).Value = "X" Then
With wsHH
wsHR.Range("A" & i).Copy
.Range("A" & y).PasteSpecial Paste:=xlPasteFormats
.Range("A" & y).PasteSpecial Paste:=xlPasteValues
'Range before PBS/KREBS
.Range("B" & y & ":AC" & y).Value = wsHR.Range("B" & i & ":AC" & i).Value
'Adds space to keep formulas for PBS/KREBS
'Range after PBS/KREBS
.Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value
End With
y = y + 1
End If
End If
Next i
'Message Box when tasks are completed
MsgBox "Complete"
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I cannot use the same conditional formatting rules in the second sheet, wsHH, because not all of the values from wsHR are pasted. The conditional formatting is based on duplicates.

Answer 1

Found a work-around to get the formatting. Previously, you were not able to access the interior color from conditional formatting in VBA without going through a lot of extra work (see here). However, I discovered as of Excel 2010, this was changed (see here). Since I'm using Excel 2013, I am able to use .DisplayFormat to find the interior color regardless of formatting (see here).
Using this, I changed:
With wsHH
wsHR.Range("A" & i).Copy
.Range("A" & y).PasteSpecial Paste:=xlPasteFormats
.Range("A" & y).PasteSpecial Paste:=xlPasteValues
'Range before PBS/KREBS
.Range("B" & y & ":AC" & y).Value = wsHR.Range("B" & i & ":AC" & i).Value
'Adds space to keep formulas for PBS/KREBS
'Range after PBS/KREBS
.Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value
End With
to this:
With wsHH
'Range before PBS/KREBS
.Range("A" & y & ":AC" & y).Value = wsHR.Range("A" & i & ":AC" & i).Value
'Adds space to keep formulas for PBS/KREBS
'Applying background CF color to new sheet
If wsHR.Range("A" & i).DisplayFormat.Interior.ColorIndex > 0 Then
.Range("A" & y).Interior.ColorIndex = 3
End If
'Range after PBS/KREBS
.Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value
End With
I am no longer copying and pasting values. Instead, I set the values using .Value like I had been for the other cells in the row, and then use the outcome of If wsHR.Range("A" & i).DisplayFormat.Interior.ColorIndex > 0 Then to determine if the second sheet's cell should be formatted.

Answer 2

I wrote some more complete and customizable/parameterized copy subs to complete this task in a quite performant way. So one can decide if things like the following should be copied or not:
border styles
font styles
background color (foreground is always copied)
text wrapping
horizontal and/or vertical alignment
normal paste operation with its XlPasteType and XlPasteSpecialOperation params
by default enabled and copying the values and number formats
which would not copy conditional formatting styles applied
general example usage of custom subs below
e.g. the following call:
EventsDisable
PasteWithDisplayFormat Range("B40"), Range("A1:Z30")
EventsEnable
OP query example
in the OP example it should be something like this:
With wsHH
PasteWithDisplayFormat .Range("A" & y), wsHR.Range("A" & i)
'...
End With
instead of:
With wsHH
wsHR.Range("A" & i).Copy
.Range("A" & y).PasteSpecial Paste:=xlPasteFormats
.Range("A" & y).PasteSpecial Paste:=xlPasteValues
'...
End With
custom subs
(please feel free to enhance/extend it here for others)
'including conditional formatting as fixed styles (DisplayFormat)
'based on Range.PasteSpecial
Public Sub PasteWithDisplayFormat( _
dst As Range, _
Optional src As Range, _
Optional pasteSpecialBefore As Boolean = True, _
Optional paste As XlPasteType = xlPasteValuesAndNumberFormats, _
Optional Operation As XlPasteSpecialOperation = xlNone, _
Optional SkipBlanks As Boolean = False, _
Optional Transpose As Boolean = False, _
Optional Borders As Boolean = True, _
Optional Font As Boolean = True, _
Optional InteriorColor As Boolean = True, _
Optional WrapText As Boolean = True, _
Optional HorizontalAlignment As Boolean = True, _
Optional VerticalAlignment As Boolean = True _
)
If src Is Nothing Then Set src = Selection
If pasteSpecialBefore Then dst.PasteSpecial paste:=paste, Operation:=Operation, SkipBlanks:=False, Transpose:=False
Dim x As Integer: For x = 1 To src.Rows.Count
For y = 1 To src.Columns.Count
Dim sf As DisplayFormat: Set sf = src.Cells(x, y).DisplayFormat 'source cells DisplayFormat
With dst.Cells(x, y)
If Borders Then CopyBorders .Borders, sf.Borders
If Font Then
.Font.ColorIndex = sf.Font.ColorIndex
.Font.Color = sf.Font.Color
.Font.Background = sf.Font.Background
.Font.FontStyle = sf.Font.FontStyle '=> bold + italic
'.Font.Bold = sf.Font.Bold
'.Font.Italic = sf.Font.Italic
.Font.Size = sf.Font.Size
.Font.Name = sf.Font.Name
End If
If InteriorColor Then .Interior.Color = sf.Interior.Color
If WrapText Then .WrapText = sf.WrapText
If HorizontalAlignment Then .HorizontalAlignment = sf.HorizontalAlignment
If VerticalAlignment Then .VerticalAlignment = sf.VerticalAlignment
End With
Next y
Next x
End Sub
Sub CopyBorders(dst As Borders, src As Borders)
If src.LineStyle <> xlLineStyleNone Then
dst.ColorIndex = src.ColorIndex
If src.ColorIndex <> 0 Then dst.Color = src.Color
dst.Weight = src.Weight
dst.LineStyle = src.LineStyle
dst.TintAndShade = src.TintAndShade
End If
Dim bi As Integer: For bi = 1 To src.Count 'border index
CopyBorder dst(bi), src(bi)
Next bi
End Sub
Sub CopyBorder(dst As Border, src As Border)
If src.LineStyle <> xlLineStyleNone Then
dst.ColorIndex = src.ColorIndex
If src.ColorIndex <> 0 Then dst.Color = src.Color
dst.Weight = src.Weight
dst.LineStyle = src.LineStyle
dst.TintAndShade = src.TintAndShade
End If
End Sub
'used with EventsEnable()
Sub EventsDisable()
With Application: .EnableEvents = False: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With
End Sub
'used with EventsDisable()
Sub EventsEnable()
With Application: .EnableEvents = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
End Sub
Other approaches found
temp MS Word doc approach
here is one example based on copying to a temp word file and pasting back, but (at least on more complex tables) results in the pasting of some OLE embedded object that is not really usable in excel anymore, but could suffice for other uses:
https://www.ozgrid.com/forum/forum/help-forums/excel-general/119606-copy-colors-but-not-conditional-formating?p=1059236#post1059236
xlPasteAllMergingConditionalFormats
using xlPasteAllMergingConditionalFormats as the XlPasteType seems to produce the same result like the temp MS Word doc approach above