How to convert conditional formatting into true color using VBA?

[mss90]

Hi,

If I have a table with different colors through conditional formatting, how can I convert the colored cells in this table from conditional color to true color using VBA?

Thanks

[Fluff13]

How about

Sub mss()
   Dim Cl As Range
   
   For Each Cl In ActiveSheet.UsedRange
      If Cl.DisplayFormat.Interior.Color <> 16777215 Then
         Cl.Interior.Color = Cl.DisplayFormat.Interior.Color
      End If
   Next Cl
End Sub

[mss90]

How about

Sub mss()
   Dim Cl As Range
   
   For Each Cl In ActiveSheet.UsedRange
      If Cl.DisplayFormat.Interior.Color <> 16777215 Then
         Cl.Interior.Color = Cl.DisplayFormat.Interior.Color
      End If
   Next Cl
End Sub

This does not seem to work?

[romperstomper]

Here's one way - adjust the range in the testit routine as needed:

Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" ( _
                                                ByVal wFormat As Long, ByVal lpString As String, _
                                                ByVal nMaxCount As Long) As Long

Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" ( _
                                 ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" ( _
                                 ByVal lpStr1 As Any, ByVal lpStr2 As Any) As Long
Sub testit()
    With Range("A1:F21")
        .Select
        .Copy
    End With
    PasteFormattedRange
End Sub
Sub PasteFormattedRange()
    Dim S                     As String
    Dim i As Long, CF_Format  As Long
    Dim SaveDisplayAlerts As Boolean, SaveScreenUpdating As Boolean
    Dim HTMLInClipBoard       As Boolean
    Dim Handle As Long, Ptr As Long, FileName As String

    'Enumerate the clipboard formats
    If OpenClipboard(0) Then
        CF_Format = EnumClipboardFormats(0&)
        Do While CF_Format <> 0
            S = String(255, vbNullChar)
            i = GetClipboardFormatName(CF_Format, S, 255)
            S = Left(S, i)
            HTMLInClipBoard = InStr(1, S, "HTML Format", vbTextCompare) > 0

            If HTMLInClipBoard Then
                Handle = GetClipboardData(CF_Format)
                Ptr = GlobalLock(Handle)
                Application.CutCopyMode = False
                S = Space$(lstrlen(ByVal Ptr))
                lstrcpy S, ByVal Ptr
                GlobalUnlock Ptr
                SetClipboardData CF_Format, Handle
                ActiveSheet.PasteSpecial Format:="HTML"
                Exit Do
            End If

            CF_Format = EnumClipboardFormats(CF_Format)
        Loop
        CloseClipboard
    End If

End Sub

If your Office version is actually later than the 2007 in your profile, you could also use Fluff's method.

[mss90]

Here's one way - adjust the range in the testit routine as needed:

Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" ( _
                                                ByVal wFormat As Long, ByVal lpString As String, _
                                                ByVal nMaxCount As Long) As Long

Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" ( _
                                 ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" ( _
                                 ByVal lpStr1 As Any, ByVal lpStr2 As Any) As Long
Sub testit()
    With Range("A1:F21")
        .Select
        .Copy
    End With
    PasteFormattedRange
End Sub
Sub PasteFormattedRange()
    Dim S                     As String
    Dim i As Long, CF_Format  As Long
    Dim SaveDisplayAlerts As Boolean, SaveScreenUpdating As Boolean
    Dim HTMLInClipBoard       As Boolean
    Dim Handle As Long, Ptr As Long, FileName As String

    'Enumerate the clipboard formats
    If OpenClipboard(0) Then
        CF_Format = EnumClipboardFormats(0&)
        Do While CF_Format <> 0
            S = String(255, vbNullChar)
            i = GetClipboardFormatName(CF_Format, S, 255)
            S = Left(S, i)
            HTMLInClipBoard = InStr(1, S, "HTML Format", vbTextCompare) > 0

            If HTMLInClipBoard Then
                Handle = GetClipboardData(CF_Format)
                Ptr = GlobalLock(Handle)
                Application.CutCopyMode = False
                S = Space$(lstrlen(ByVal Ptr))
                lstrcpy S, ByVal Ptr
                GlobalUnlock Ptr
                SetClipboardData CF_Format, Handle
                ActiveSheet.PasteSpecial Format:="HTML"
                Exit Do
            End If

            CF_Format = EnumClipboardFormats(CF_Format)
        Loop
        CloseClipboard
    End If

End Sub

If your Office version is actually later than the 2007 in your profile, you could also use Fluff's method.

Okay thanks, I am using the latest version unfortunately

[romperstomper]

Okay thanks, I am using the latest version unfortunately

Then I suggest you update your profile. If you are using a version later than 2007, then Fluff's code should work so you'll need to provide more information than just "doesn't seem to work". Although, what I posted should still work, unless you have 64bit Office.

[mss90]

Then I suggest you update your profile. If you are using a version later than 2007, then Fluff's code should work so you'll need to provide more information than just "doesn't seem to work". Although, what I posted should still work, unless you have 64bit Office.

I have updated my profile now, apologies for the inconvenience. I am not sure what to add as the code doesnt make the conditional formatting on the active worksheet into true colors. Nothing seems to change, it just loads for a bit.

[Fluff13]

If your Office version is actually later than the 2007 in your profile, you could also use Fluff's method.

Oops, never thought of that

[Sintek]

Are you not perhaps wanting to remove conditional formatted color rule and replace with true color...
i.e. remove the rule and replace...

[mss90]

Are you not perhaps wanting to remove conditional formatted color rule and replace with true color...
i.e. remove the rule and replace...

Yes, in other words I want to remove conditional formatting but to keep the colors

[Sintek]

Add red snippet below Fluff13 code...

Cl.Interior.Color = Cl.DisplayFormat.Interior.Color
Cl.FormatConditions.Delete

[mss90]

Add red snippet below Fluff13 code...

Cl.Interior.Color = Cl.DisplayFormat.Interior.Color
Cl.FormatConditions.Delete

Thanks, that worked perfectly!

[Sintek]

Glad I could contribute...Tx for unexpected rep +

[Fluff13]

Glad to help & thanks for the feedback.