VBA Code Add Condition

[hrayani]

Hello Friends,

I am using the this VBA Code to format dates which are greater than or equal to today.

I require to add another condition i.e. if the adjacent cell (right one) is empty then only the code should format dates otherwise nothing should happen.

Sub formatdates()

Dim rngCell As Range
Dim lngLstRow As Long
Dim strCol(1 To 9) As String


strCol(1) = "N"
strCol(2) = "P"
strCol(3) = "R"
strCol(4) = "T"
strCol(5) = "V"
strCol(6) = "X"
strCol(7) = "Z"
strCol(8) = "AB"
strCol(9) = "AD"


lngLstRow = ActiveSheet.UsedRange.Rows.Count


    For I = 1 To 9
        For Each rngCell In Range(strCol(I) & "4:" & strCol(I) & lngLstRow)
            If rngCell.Value >= Now() Then
                rngCell.Font.ColorIndex = 3
                
            Else
                rngCell.Font.ColorIndex = 1
                
            End If
        Next
    Next I


End Sub

Any help would be appreciated.

Regards,

Humayun

 

[hrayani]

Hi Fluff,

Code Is Working Fine. I amended a code a bit for my additional requirements.


From This

If .Offset(, 1).Value = "" And .Value <= Date Then

To This - Coz I wanted another criteria i.e. if Date is blank then nothing should happen

If .Offset(, 1).Value = "" And .Value <= Date And .Value <> "" Then

From This

.Offset(, 1).Value = Date - .Value

To This - Coz I wanted text like 45 Day(s)

.Offset(, 1).Value = Date - .Value & " Day(s)"

So far its working fine. I am working on few more things like if the days difference is a single day then Day should be there instead of Days and if the difference is 0 then it should show Today etc.

First I will try then will bother you if I fail to accomplish.

Keep you posted.

Regards,

Humayun

 

[Fluff]

You're welcome & thanks for the feedback

 

[hrayani]

Hello Fluff

This is what I have come up with

If .Offset(, 1).Value = "" And .Value < Date And Date - .Value > 1 And .Value <> "" Then               .Resize(, 2).Font.ColorIndex = 3
               .Offset(, 1).Value = Date - .Value & " Days"
            
            ElseIf .Offset(, 1).Value = "" And .Value < Date And Date - .Value = 1 And .Value <> "" Then
               .Resize(, 2).Font.ColorIndex = 3
               .Offset(, 1).Value = Date - .Value & " Day"
            
            ElseIf .Offset(, 1).Value = "" And .Value = Date And .Value <> "" Then
               .Resize(, 2).Font.ColorIndex = 3
               .Offset(, 1).Value = "Today"

If date difference is > 1 day Then For example 2 Days
If date difference is = 1 day Then 1 Day
If date difference is = 0 i.e. current date Then Today


I am not sure if there is a better way to write it...

 

[Fluff]

If it works, it's good
Added to which you understand it, so easier for you to modify in future if needed.

 

[hrayani]

Hi Fluff,

I am having a problem. The data on which this code is being applied is copied from a different worksheet to the current worksheet.

i.e. copy then paste special > values.

Some are results of formula. For example

=IF(A1=B1,"")

and if the logic is met then the answer returns

""

- then it is copied and then paste special as value to the current worksheet. So when this happens the code debugs whith the first line of the code highlighted and giving a msg > runtime error 13 - type mismatch

 If .Offset(, 1).Value = "" And .Value < Date And Date - .Value > 1 And .Value <> "" Then        
        .Resize(, 2).Font.ColorIndex = 3
        .Offset(, 1).Value = Date - .Value & " Days"
            
     ElseIf .Offset(, 1).Value = "" And .Value < Date And Date - .Value = 1 And .Value <> "" Then
        .Resize(, 2).Font.ColorIndex = 3
        .Offset(, 1).Value = Date - .Value & " Day"
            
     ElseIf .Offset(, 1).Value = "" And .Value = Date And .Value <> "" Then
        .Resize(, 2).Font.ColorIndex = 3
        .Offset(, 1).Value = "Today"

Kindly let me know how to overcome this issue

 

[Fluff]

Check that you don't have any errors in the cells. ie #N/A, #VALUE! etc

 

[hrayani]

Check that you don't have any errors in the cells. ie #N/A, #VALUE ! etc

No there are no errors as I have applied iferror on all formulas

 

[Fluff]

In that case you will need to check that the cell isn't "" before you subtract it from Date.

            If .Value <> "" Then
               If .Offset(, 1).Value = "" And .Value < Date And Date - .Value > 1 Then

 

[hrayani]

I tried but getting debug msg. Compile error ... End with without with


Also I wanted if the cell has "Not Applicable" in there then the code should not turn it to red

I did a bit of experiment and came up with this
Red Parts added in the code.

  [B][COLOR=#ff0000]On Error Resume Next[/COLOR][/B]            
    If .Offset(, 1).Value = "" And .Value < Date And Date - .Value > 1 And .Value <> "" Then
     .Resize(, 2).Font.ColorIndex = 3
     .Offset(, 1).Value = Date - .Value & " Days"
            
    ElseIf .Offset(, 1).Value = "" And .Value < Date And Date - .Value = 1 And .Value <> "" Then
     .Resize(, 2).Font.ColorIndex = 3
     .Offset(, 1).Value = Date - .Value & " Day"
            
    ElseIf .Offset(, 1).Value = "" And .Value = Date And .Value <> "" Then
     .Resize(, 2).Font.ColorIndex = 3
     .Offset(, 1).Value = "Today"
            
    
     
            Else
               .Resize(, 2).Font.ColorIndex = 1
            End If
         
[COLOR=#ff0000][B]         If .Value = "Not Applicable" Then[/B][/COLOR]
[COLOR=#ff0000][B]         .Resize(, 2).Font.ColorIndex = 1[/B][/COLOR]
         
         End If
         End With
      Next rngCell
   Next I

Kindly let me know if its OK

 

[Fluff]

Let's stick to one problem at a time. You have not changed the if statements as I showed.
Also NEVER use "On Error Resume Next" in that manner, as it will simply hide problems.