Excel VBA conditional formatting

Here is the code:

Public Function expTrends(strMonth, strYear As String)

    Dim xlApp As Excel.Application
    Dim xlWb As Excel.Workbook
    Dim xlWs As Excel.Worksheet
    Dim xlRng As Excel.Range
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim fld As DAO.Field
    Dim x, y, z As Integer
    Dim sqltxt As String
    Dim aryHeader(29) As String
    Dim wsCnt As Integer
    Dim strFile As String
    Dim mkTblQry As String
    Dim tblToMake As String
    Dim strFileName As String
    Dim strMoveMonth As String
   
   
   
    strFileName = CCFILENAME & strYear & ".xlsx"
    'strFileName = SaveLocation()
   
    'strFile = SaveLocation()
    'Debug.Print strFile
    'If strFile = "" Then
     '   MsgBox ("Exiting Export")
      '  GoTo ExitHere
    'End If
   
    Set db = Access.CurrentDb
   
    aryHeader(1) = "Material"
    aryHeader(2) = "Description"
    aryHeader(3) = "Product" & vbCrLf & "Hierarchy"
    aryHeader(4) = "Base" & vbCrLf & "Hierarchy"
    aryHeader(5) = "Base" & vbCrLf & "Description"
    aryHeader(6) = "Sub" & vbCrLf & "Hierarchy"
    aryHeader(7) = "Sub" & vbCrLf & "Description"
    aryHeader(8) = "Profit" & vbCrLf & "Center"
    aryHeader(9) = "Division"
    aryHeader(10) = "Ea to Case"
    aryHeader(11) = "BUOM"
    aryHeader(12) = "Globe Std Cost"
    aryHeader(13) = "Calculated" & vbCrLf & "BUOM Std"
    aryHeader(14) = "Quantity total BI" & vbCrLf & "@ Act"
    aryHeader(15) = "Quantity total Acq" & vbCrLf & "@ Act"
    aryHeader(16) = "Quantity total" & vbCrLf & "Sales @ Act"
    aryHeader(17) = "Quantity total EI" & vbCrLf & "@ Act"
    aryHeader(18) = "Value total BI" & vbCrLf & "@ Act"
    aryHeader(19) = "Value total Acq" & vbCrLf & "@ Act"
    aryHeader(20) = "Value total" & vbCrLf & "Sales @ Act"
    aryHeader(21) = "Value total EI" & vbCrLf & "@ Act"
    aryHeader(22) = "Base qty BI"
    aryHeader(23) = "Base qty Acq"
    aryHeader(24) = "Base qty Sales"
    aryHeader(25) = "Base qty EI"
    aryHeader(26) = "Unit cost BI"
    aryHeader(27) = "Unit cost Acq"
    aryHeader(28) = "Unit cost Sales"
    aryHeader(29) = "Unit cost EI"

    If strMonth = "Jan" Then
        Set xlApp = New Excel.Application
        Set xlWb = xlApp.Workbooks.Add
    Else
        Set xlApp = New Excel.Application
        Set xlWb = xlApp.Workbooks.Open(strFileName)
    End If
    xlApp.Application.DisplayAlerts = False
    xlApp.Visible = True
    Set xlWs = xlWb.Worksheets.Add
    xlWs.Name = strMonth & " " & strYear
    'Set xlWs.Name = "Jan"
   
    Select Case strMonth
        Case "Feb"
            strMoveMonth = "Jan"
        Case "Mar"
            strMoveMonth = "Feb"
        Case "Apr"
            strMoveMonth = "Mar"
        Case "May"
            strMoveMonth = "Apr"
        Case "Jun"
            strMoveMonth = "May"
        Case "Jul"
            strMoveMonth = "Jun"
        Case "Aug"
            strMoveMonth = "Jul"
        Case "Sep"
            strMoveMonth = "Aug"
        Case "Oct"
            strMoveMonth = "Sep"
        Case "Nov"
            strMoveMonth = "Oct"
        Case "Dec"
            strMoveMonth = "Nov"
    End Select
   
    Set rs = db.OpenRecordset("qryTrendMonthly", dbOpenDynaset)
   
    Set xlWs = xlWb.ActiveSheet
        x = 1
        For Each fld In rs.Fields
             With xlWs.Cells(1, x)
                .Value = aryHeader(x)
                .BorderAround xlContinuous, xlThin, 5
                .RowHeight = 48
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
               
                If x < 13 Then
                    .Interior.Color = RGB(192, 192, 192)
                End If
                If x = 13 Then
                    .Interior.Color = RGB(204, 255, 204)
                End If
                If x > 13 And x < 18 Then
                    .Interior.Color = RGB(255, 204, 153)
                End If
                If x > 17 And x < 22 Then
                    .Interior.Color = RGB(192, 192, 192)
                End If
                If x > 21 And x < 26 Then
                    .Interior.Color = RGB(204, 255, 255)
                End If
                If x > 25 Then
                    .Interior.Color = RGB(204, 255, 204)
                End If
            End With
            x = x + 1
        Next fld
   
    Set xlRng = xlWs.Cells(2, 1)
    xlRng.CopyFromRecordset rs
    xlWs.Columns.AutoFit
    xlWs.Columns("D").ColumnWidth = 9
   
   
    Set xlRng = xlWs.Cells.SpecialCells(xlCellTypeLastCell)
       
        z = xlRng.Column
        x = xlRng.Row
       
        'For y = 6 To z
         '   Set xlRng = xlWs.Cells(x, y)
         '   If y = 6 Then
         '       xlRng.Value = "TOTALS"
         '       xlRng.Font.Bold = True
         '   End If
         '   If Not y = 6 Then
         '       xlRng.FormulaR1C1 = "=Subtotal(9,R2C:R[-2]C)"
         '       xlRng.Font.Bold = True
         '   End If
        'Next y
       
        ' Shade the first 10 columns yellow (below the headers)
        'x = x - 2
        Set xlRng = xlWs.Range(xlWs.Cells(2, 1), xlWs.Cells(x, 9))
        xlRng.Interior.Color = RGB(255, 255, 204)
       
        ' Format worksheet columns
        'xlWs.Columns.AutoFit
        'Set xlRng = xlWs.Columns("N:AC")
        Set xlRng = xlWs.Range(xlWs.Cells(2, 14), xlWs.Cells(x, z))
        xlRng.NumberFormat = "###,###,###,##0.00;[Red](###,###,###,##0.00"
        Set xlRng = xlWs.Columns("J")
        xlRng.NumberFormat = "###,###,###,##0.000;[Red](###,###,###,##0.000)"
       
       
        xlWs.Range("A1").Select
        With xlApp.ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
        End With
        xlApp.ActiveWindow.FreezePanes = True
   
        If strMonth = "Jan" Then
            xlWb.Sheets("Sheet3").Delete
            xlWb.Sheets("Sheet2").Delete
            xlWb.Sheets("Sheet1").Delete
        End If
       
        Select Case strMonth
        Case "Jan"
            x = 1
        Case "Feb"
            x = 2
        Case "Mar"
            x = 3
        Case "Apr"
            x = 4
        Case "May"
            x = 5
        Case "Jun"
            x = 6
        Case "Jul"
            x = 7
        Case "Aug"
            x = 8
        Case "Sep"
            x = 9
        Case "Oct"
            x = 10
        Case "Nov"
            x = 11
        Case "Dec"
            x = 12
    End Select
        If strMonth <> "Jan" Then
            xlWb.Sheets(strMonth & " " & strYear).Move After:=xlWb.Sheets(strMoveMonth & " " & strYear)
        End If
       
        If strMonth = "Jan" Then
            xlWb.SaveAs strFileName
        End If
        xlApp.Application.DisplayAlerts = True
       
        rs.Close
        xlApp.Quit
       
        Set fld = Nothing
        Set rs = Nothing
        Set qry = Nothing
        Set db = Nothing
        Set xlRng = Nothing
        Set xlWs = Nothing
        Set xlWb = Nothing
        Set xlApp = Nothing
       
        DoCmd.SetWarnings WarningsOn
       
        Call DefineArray(strMonth, strYear)
   
End Function

If you want to compare let's say Column C with Column B then add this to your code.

    With xlWs.Columns("C:C")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=OR(C1>B1,C1<B1)"
        .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 255
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With

Select allOpen in new window

Sid

Thanks SiddharthRout, but I am still having a problem...I am now getting a 'Run-time error 9  Subscript out of range' error with the line .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority highlighted.  Here is how I tried to adapt your suggestion to my situation:

Set xlRng = xlWs.Cells.SpecialCells(xlCellTypeLastCell)
       
        z = xlRng.Column
        x = xlRng.Row
       
       
        Set xlRng = xlWs.Range(xlWs.Cells(2, 1), xlWs.Cells(x, 9))
        xlRng.Interior.Color = RGB(255, 255, 204)
       
        ' Format worksheet columns
        'xlWs.Columns.AutoFit
        'Set xlRng = xlWs.Columns("N:AC")
        Set xlRng = xlWs.Range(xlWs.Cells(2, 14), xlWs.Cells(x, z))
        xlRng.NumberFormat = "###,###,###,##0.00;[Red](###,###,###,##0.00"
        xlRng.ColumnWidth = 13.71
        Set xlRng = xlWs.Columns("J")
        xlRng.NumberFormat = "###,###,###,##0.000;[Red](###,###,###,##0.000)"
       
        '###############################################################################
        Set xlRng = xlWs.Range(xlWs.Cells(2, 14), xlWs.Cells(x, 18))
        With xlRng
        For w = 2 To x
            For y = 15 To 18
        .FormatConditions.Add Type:=xlExpression, _
            Formula1:="=OR(xlWs.Cells(w,y)>xlWs.Cells(w,y-1),xlWs.Cells(w,y)<xlWs.Cells(w,y-1))"
        .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 255
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
            Next y
        Next w
        End With

What am I still missing??

Oops a typo...

Delete that "Selection" so the line

.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

becomes

.FormatConditions(.FormatConditions.Count).SetFirstPriority

Sid

Well, i am still having problems getting the code to work.  It is running OK.  I verified by placing a Debug.Print line inside the loop and watching the counter increment.  However I am getting no change in the font or interior color of the cells that should be affected by the formatting, namely those that have a value which is not the same as the cell to its left.

Quick Question.

Why are you using loops 'w' and 'y'? Why not simply select the range and directly apply the formatting?

Sid

This is the method that was recommended to me by a colleague.  As I mentioned, I am a virtual novice when it comes to VBA.  How would you solve this problem...can I just remove the loop structure?

Yes. Directly apply the formatting to the range as I did in ID: 34826432

Sid

I cut and pasted the code you provided only changing the columns I wanted to compare and removing the word Selection that we discovered yesterday, but I am still having no success.  I don't understand it, there is no formatting taking place after the code we inserted, and it runs and exports the spreadsheet with no errors, but every value in colunm O that I would expect to be formatted with red font is still black.  Her is the code:

With xlWs.Columns("O:O")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=OR(O1>N1,O1<N1)"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 255
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
        End With

Can you upload the excel workbook which is created?

Sid

This is the spreadsheet that I am creating within Access and exporting to Excel.  What I want is to have certain columns compared with their neighboring column to the left (which will hold the previous months data) and have that column's text displayed in red is it has changed from the previous month.  This is only the data for January and the formatting will only need to take place on the Trend file actual costs worksheet. Case-Costs-2011.xlsx

Ok Let me test it for you...

Paste the code that you are using at the moment.

Sid

I just notice that you need to declare this at the top of the Access Code.

Const xlExpression as Long = 2

Sid

I inserted the declaration for the constant xlExpression in the general declaration area of the module in which the procedure exists and ran it again, and still column O is all black font.

Yeah I noticed in the excel file that in the column it is putting the formula but it is referring to a different range. I just need to see the complete code that you are using so that I can test it from my side.

Sid

OK here you go...and I really appreciate all the time you're spending on this.  I've attached a text file with the three procedures I use to create the spreadsheet.  The last one is the one that creats the Trends sheet. ExportCaseCosts.txt

Gang,

Setting Conditional Formatting formula-based rules that use relative references is one of the very few instances where you actually DO have to select a range.

For example, I adapted Sid's code from http:#a34826432, and ran it in a case where the ActiveCell was A1:

Sub test()
    
    With ActiveSheet.Columns("C:C")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=C1<>B1"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 255
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
End Sub

Select allOpen in new window

When I did that, I did not get the results I expected.  Indeed, when I went to check out the CF that did get applied, the formula for C1 was =E1<>D1.

However, when I first issued a Select on C1, I got the result I expected:

Sub test()
    
    [c1].Select
    
    With ActiveSheet.Columns("C:C")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=C1<>B1"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 255
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
End Sub

Select allOpen in new window

Patrick

Few things that I noticed...

I will type it as I read through your code so that I don't forget later.

1) Don't use a Function. Use a Sub. Function is used when you want to return something.
2) I see that you are using DAO. DAO is now obsolete. Use ADO instead.
3) Dim w, x, y, z As Integer

Please note that in VBA w,x,y will be declared as variant and only z will be declared as Integer. To declare all of them as integer declare it as

Dim w As Integer, x As Integer, y As Integer, z As Integer

4) I also noticed above that you want to change the font and not the cell color? If that is what you want then the code will be slightly different.

5) BTW, I tested the code by removing all the code referring to the database and ran this code. It just worked fine...

Sub ExportCaseCost()
    Dim xlWs As Worksheet
    Set xlWs = Sheets("Trend file actual costs")
        
    With xlWs.Columns("O:O")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=OR(O1>N1,O1<N1)"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Color = -16776961
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

Select allOpen in new window

Try putting this piece of code at the end of your code just before you are closing the Excel File

Sid

Good Point Patrick :)

Sid

OK, now I do see the formatting formula, but as Pactric points out it is on the wrong column,  In fact its on column O, but refers to columns AC & AB, which are the last two columns on the other worksheet.  What is the syntax to Select the correct range from my access code before applying the conditional formatting?

Try this

Sub ExportCaseCost()
    Dim xlWs As Worksheet
    Set xlWs = Sheets("Trend file actual costs")
        
    xlWs.Range("O1").Select
    
    With xlWs.Columns("O:O")
        .FormatConditions.Add Type:=xlExpression, Formula1:="=OR(O1>N1,O1<N1)"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Color = -16776961
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

Select allOpen in new window

Sid

Getting very close...it worked, but only for the first row...Only the column header for column O turned red...I want each consecutive pair of values in each row, for all rows to be compared.  And then eventually it will have to compare each consecutive pair over a range of 12 columns, but I'm sure I'll be able to figure that out once I get over this first hurdle.

Ok try this

Repalce

xlWs.Range("O1").Select

by

xlWs.Range("O:O").Select

Now try.

Sid

Ooops my mistake, it is working fine for the whole column..I mistakenly populated the same month twice, so there were no differences in the data....so can I just string together more columns in the formula in order to include more columns in the comparison?

Yes, but chnage the code accordingly specially .Select Part as Patrick suggested.

Sid

I think I've got the hang of it now...Thank you so much Sid and Patrick...you quite possibly saved the whole project.  I am very appreciative.

Glad to be of help :)

Sid

cekendricks: I believe you did an incorrect allocation of points. The points should have been equally split between me and Patrick. :)

Sid

I realize that Patrick deserves a lot of credit also, but didn't know how to award both of you.  And now my employers want another field to be highlighted in a different way.  In other words they've changed the requirements.  I posted a new question.

Don't worry :) I have already requested a mod :)

Looking at your other question now.

Sid

My problem was completely resolved