Excel VBA loop through range to find Type of FormatCondition

Question

My issue:

I want to loop through a range, and whenever it finds a coloured cell, it should copy the cell to the left to the cell to the right of it. And then afterwards paste it into an other worksheet.

My sheet called “Compare” compares two sets of data, whereas a FormatConditions is applied as xlUniqueValues... The two sets of data, should contain the same data, but sometimes, there will be some, which are not within the other range. It is these cells that I am interested in finding with my loop, and then doping the processes if the criteria is met.

My code doesn't loop through the cells and returns me this message:

Run-time error '438': Object doesn't support this property or method

A screenshot of some of the data in Sheet "Compare":

My Code:

    Sub LoopForCondFormatCells()

    Dim sht3, sht4 As Worksheet
    Dim ColB, c As Range
    Set sht3 = Sheets("Compare")
    Set sht4 = Sheets("Print ready")

    ColB1 = sht3.Range("G3:G86")
    Set ColB = Range(ColB1)

   For Each c In ColB.Cells
   If c.FormatConditions.Type = xlUniqueValues Then 'Error here!
        CValue = c.Address(False, False, xlA1)
        CValueOffsetL = sht3.Range(CValue).Offset(0, -1).Address(False, False, xlA1)
        CValueOffsetR = sht3.Range(CValue).Offset(0, 1).Address(False, False, xlA1)
        sht3.Range(CValueOffsetL, CValueOffsetR).Copy
        KvikOffIns = sht4.Range(HosKvikOff).Offset(0, -1).Address(False, False, xlA1)
        sht4.Range(KvikOffIns).PasteSpecial xlPasteAll
        End If
    Next c

Goal:

I want the macro to loop through the cells, and find whatever cells, which has the FormatConditions type "xlUniqueValues". Whenever it comes across a cell, which is FormatConditions type "xlUniqueValues", it should do the steps:

CValue = c.Address(False, False, xlA1)
CValueOffsetL = sht3.Range(CValue).Offset(0, -1).Address(False, False, xlA1)
CValueOffsetR = sht3.Range(CValue).Offset(0, 1).Address(False, False, xlA1)
sht3.Range(CValueOffsetL, CValueOffsetR).Copy
KvikOffIns = sht4.Range(HosKvikOff).Offset(0, -1).Address(False, False, xlA1)
sht4.Range(KvikOffIns).PasteSpecial xlPasteAll

What should I write in my "If c Is" line to get the macro to do what I want it to do?

Answer 1

There a a number of issues in your code

1. Declare all variables. (Include Option Explicit at top of module to force this
2. Be specific on all declarations (Dim sht3, sht4 As Worksheet declares sht3 as Variant)
3. Your method of referencing ranges is convoluted and confusing and unnecassary
4. c.FormatConditions is a Collection of conditional formats, and doesn't have a Type. Iterate the collection and test the Type of each
5. You are copying everything, including the conditional formats. Is that your intent? If not, I'll update answer to show a different way

refactored code so far

Option Explicit

Sub LoopForCondFormatCells()

    Dim sht3 As Worksheet, sht4 As Worksheet
    Dim ColB As Range, c As Range
    Dim ColB1 As Range

    Dim HosKvikOff As Range
    Dim n As Long

    Set sht3 = Worksheets("Compare")
    Set sht4 = Worksheets("Print ready")

    Set HosKvikOff = sht4.Range("A1")  ' <-- update to suit

    Set ColB1 = sht3.Range("G3:G86")

    For Each c In ColB1.Cells
        With c.FormatConditions
            For n = 1 To .Count
                If .Item(n).Type = xlUniqueValues Then
                    c.Offset(0, -1).Resize(1, 3).Copy
                    HosKvikOff.PasteSpecial xlPasteAll
                    Set HosKvikOff = HosKvikOff.Offset(1, 0)  ' Increment output row
                End If
            Next

        End With
    Next
End Sub

---

A method not relying of Conditional Formatting

Option Explicit

Sub LoopForCondFormatCells()
    Dim sht3 As Worksheet, sht4 As Worksheet
    Dim ColB As Range, c As Range
    Dim ColB1 As Range

    Dim HosKvikOff As Range
    Dim n As Long

    Set sht3 = Worksheets("Compare")
    Set sht4 = Worksheets("Print ready")

    Set HosKvikOff = sht4.Range("A1")

    Set ColB1 = sht3.Range("G3:G86")

    ' Copy Non-duplicates
    For Each c In ColB1.Cells
        If Not IsEmpty(c) Then
            n = Application.WorksheetFunction.CountIfs(ColB1, c)
            If n = 1 Then
                c.Offset(0, -1).Resize(1, 3).Copy
                HosKvikOff.PasteSpecial xlPasteAll
                Set HosKvikOff = HosKvikOff.Offset(1, 0)
            End If
        End If
    Next

End Sub