VBA Conditional Formating Formula Problem

[baha17]

Dear ALL,
I made a code to assign conditional formating on one specific rage. That range change as with the entries and on column F if the data is 4; column B to F for that row should be strike through and red color. However, something is wrong.If I check the individual cell's conditional formating; formula does not math with the code.Example, when I check B2; conditional formatting formula appears =$F65534=4 instead of =$F2=4.
Anybody to help me with this code, I would greatly apperiaciated.
Baha

Sub DisplayExSwing1()
    Dim LastRow As Long
    Dim cel As Range
    LastRow = Sheets("ExSwing").Range("A65536").End(xlUp).Row   
For Each cel In Sheets("ExSwing").Range("B2:F" & LastRow)
    cel.FormatConditions.Add Type:=xlExpression, Formula1:="=$F" & cel.Row & "=4"
    With cel.FormatConditions(1).Font
        .Strikethrough = True
        .Color = 255
    End With
    cel.FormatConditions(1).StopIfTrue = True
   Next cel
    Sheets("ExSwing").Range("IP1") = 1
    Columns("C:C").ColumnWidth = 15
    
End Sub

 

[AlphaFrog]

Try this...

[color=darkblue]Sub[/color] DisplayExSwing1()
    [color=darkblue]With[/color] Sheets("ExSwing")
        [color=darkblue]With[/color] .Range("B2:F" & .Range("A" & .Rows.Count).End(xlUp).Row)
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$F2=4"
            [color=darkblue]With[/color] .FormatConditions(1).Font
                .Strikethrough = [color=darkblue]True[/color]
                .Color = 255
            [color=darkblue]End[/color] [color=darkblue]With[/color]
            .FormatConditions(1).StopIfTrue = True
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        .Range("IP1") = 1
        .Columns("C:C").ColumnWidth = 15
    [color=darkblue]End[/color] [color=darkblue]With[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[baha17]

Hello AlphaFrog,
Thank you for your help.
It worked at if it run once only. but actually every 2 minutes file updates itself and get data from access database. Once that refresh action done formulas changes.I post my codes as well as my refresh code.I changed the name into ConFormat.

Option Explicit
Const TARGET_DB1 = "DB_M_Allocation.mdb"
Const TARGET_DB2 = "DB_S_Allocation.mdb"
Const TARGET_DB3 = "DB_G_Allocation.mdb"
Const TARGET_DB4 = "DB_StaffReq.mdb"
Const TARGET_DB5 = "DB_S_StaffReq.mdb"
Const TARGET_DB6 = "DB_G_StaffReq.mdb"
Const TARGET_DB7 = "CPUsersDB.mdb"
Const TARGET_DB8 = "ColorCodeDB.mdb"
Const TARGET_DB9 = "DB_Staff.mdb"

Const CopyTarget_DB1 = "DB_M_AllocationBackUp.mdb"
Const CopyTarget_DB2 = "DB_S_AllocationBackUp.mdb"
Const CopyTarget_DB3 = "DB_G_AllocationBackUp.mdb"
Const CopyTarget_DB4 = "DB_StaffReqBackUp.mdb"
Const CopyTarget_DB5 = "DB_S_StaffReqBackUp.mdb"
Const CopyTarget_DB6 = "DB_G_StaffReqBackUp.mdb"
Const CopyTarget_DB7 = "CPUsersDBBackUp.mdb"
Const CopyTarget_DB8 = "ColorCodeBackUp.mdb"
Const CopyTarget_DB9 = "DB_StaffBackUp.mdb"
Sub Remember()
Application.ScreenUpdating = False
ThisWorkbook.Activate
If ThisWorkbook Is ActiveWorkbook Then
Dim sht As Variant
sht = ActiveSheet.Name
Sheets(sht).Select
TrdTime = Now + TimeValue("00:01:58")
Application.OnTime TrdTime, "Remember"
CheckReminder
MakeUp
TransferTableFromAccess_tblStaff
TransferTableFromAccess_tblColorCode
ColorMeUp
Sheets(sht).Select
Range("B1").Select
FilteringPit
TimeConflict
End If
Select Case ActiveSheet.Name
Case Is = "MorningFloorMap", "SwingFloorMap", "GraveFloorMap"
If Sheets("Needs").Range("IC1") = "" Then
WidthsSmall
Exit Sub
End If
If Sheets("Needs").Range("IC1") = 1 Then
WidthsBigger
Exit Sub
End If
End Select
'Application.ScreenUpdating = True
End Sub
Sub CheckReminder()
ShowingAll
TransferTblFrAccess_MorningAll
TransferTblFrAccess_SwingAll
TransferTblFrAccess_GraveAll
DisplayNeeds
DisplaySpares
DisplayAlterations
DisplayExSwing
ConFormat
FilteringPit
MakingTheList
End Sub

Sub DisplayExSwing()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim MyConn
Dim i As Long
Dim LastRow As Long
Dim cel As Range
LastRow = Sheets("ExSwing").Range("A65536").End(xlUp).Row
Dim ShDest As Worksheet
Set ShDest = Sheets("ExSwing")
Set cnn = New ADODB.Connection
Sheets("ExSwing").Range("IP1") = 0
MyConn = ActiveWorkbook.Path & "\" & "DataFiles\" & TARGET_DB4
With cnn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Open MyConn
End With
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseServer
rst.Open Source:="tblExSwing", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
ShDest.Activate
'MsgBox Range("A1").CurrentRegion.Offset(1, 0).Address
Range("A1").CurrentRegion.Offset(1, 0).Clear
i = 0
With Range("A1")
For Each fld In rst.Fields

.Offset(0, i).Value = fld.Name
i = i + 1

Next fld
End With

'transfer data to Excel
Range("A2").CopyFromRecordset rst

' Close the connection
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Sheets("ExSwing").Range("IP1") = 1
Sheets("ExSwing").Columns("C:C").ColumnWidth = 15
'ConFormat
End Sub
Sub ConFormat()
With Sheets("ExSwing")
.Range("IP1") = 0
With .Range("B2:F" & .Range("A" & .Rows.Count).End(xlUp).Row)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$F2=4"
With .FormatConditions(1).Font
.Strikethrough = True
.Color = 255
End With
.FormatConditions(1).StopIfTrue = True
End With
.Range("IP1") = 1
.Columns("C:C").ColumnWidth = 15
End With
End Sub

 

[AlphaFrog]

Sorry. The cell references in CF formulas are relative to the Active cell. This selects cell B2 first. The CF formulas should then be correct.

    With Sheets("ExSwing")
[COLOR=#ff0000]        Application.Goto .Range("B2")[/COLOR]
        With .Range("B2:F" & .Range("A" & .Rows.Count).End(xlUp).Row)
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$F2=4"
            With .FormatConditions(1).Font
                .Strikethrough = True
                .Color = 255
            End With
            .FormatConditions(1).StopIfTrue = True
        End With
        .Range("IP1") = 1
        .Columns("C:C").ColumnWidth = 15
    End With

 

[baha17]

Thank you for your help.I could pnly try torrow.I will let you know for the feedback.See you

 

[baha17]

Hi AlphaFrog,
It worked perfectly well.Thank you very much for your help.
Have a nice day
Baha