Pasting Conditional Formatting

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

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

Answer 2

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.