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

 

[Fluff]

Try

    For i = 1 To 9
        For Each rngcell In Range(strCol(i) & "4:" & strCol(i) & lngLstRow)
            If rngcell.Offset(, 1) = "" Then
               If rngcell.Value >= Date Then
                   rngcell.Font.ColorIndex = 3
                   
               Else
                   rngcell.Font.ColorIndex = 1
                   
               End If
            End If
        Next
    Next i

 

[hrayani]

Hi Fluff,

Thanks for the solution. Working PERFECT

Kind Regards

 

[Fluff]

You're welcome & thanks for the feedback

 

[dmt32]

Hi,
try

For I = 1 To 9
        For Each rngCell In Range(strCol(I) & "4:" & strCol(I) & lngLstRow)
         With rngCell
                .Font.ColorIndex = IIf(.Offset(, 1).Value = "" And .Value >= Date, 3, 1)
        End With
        Next
    Next I

Dave

 

[hrayani]

Thanks Dave

Will try that too

 

[dmt32]

Thanks Dave

Will try that too

You are welcome - I don't type as fast as Fluff - solution untested but hopefully will work.

Dave

 

[hrayani]

Hi Fluff & Dave

Code is not looking at the right cell to turn back black again the left cell when the data is there.

I did not notice it yesterday as the data is been copied from another worksheet to the current worksheet.
So if its a fresh data then its fine - otherwise the code is not working if any change is made in the current data

Dave solution is working fine.


Full Code

Sub fluff()

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


strCol(1) = "A"
strCol(2) = "C"
strCol(3) = "E"
strCol(4) = "G"




lngLstRow = ActiveSheet.UsedRange.Rows.Count


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


End Sub

Dave Code

Sub dave()

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


strCol(1) = "A"
strCol(2) = "C"
strCol(3) = "E"
strCol(4) = "G"




lngLstRow = ActiveSheet.UsedRange.Rows.Count


    For I = 1 To 4
        For Each rngCell In Range(strCol(I) & "4:" & strCol(I) & lngLstRow)
         With rngCell
                .Font.ColorIndex = IIf(.Offset(, 1).Value = "" And .Value >= Date, 3, 1)
        End With
        Next
    Next I
End Sub

 

[hrayani]

Hello,

I want a bit more from this code. One more thing needs to be added in the IF Function if possible.

If cell Value <= Date and adjacent cell is empty than I want a value in the adjacent cell & that should be today date minus cell date - besides the cell turning red which is fine and yes I would also want the adjacent cell to turn red also

For example cell has date lets say 10/7
Then the adjacent cell should show "5 Days Over" in there as current date is 15/7.
I want the difference of two dates.

Here is the code

Sub formatdates()Dim rngCell As Range
Dim lngLstRow As Long
Dim strCol(1 To 4) As String


strCol(1) = "A"
strCol(2) = "C"
strCol(3) = "E"
strCol(4) = "G"


lngLstRow = ActiveSheet.UsedRange.Rows.Count


    For I = 1 To 4
        For Each rngCell In Range(strCol(I) & "4:" & strCol(I) & lngLstRow)
         With rngCell
                .Font.ColorIndex = IIf(.Offset(, 1).Value = "" And .Value <= Date, 3, 1)
        End With
        Next
    Next I
    End Sub

 

[Fluff]

How about

Sub formatdates()
   Dim rngCell As Range
   Dim lngLstRow As Long
   Dim strCol(1 To 4) As String
   
   
   strCol(1) = "A"
   strCol(2) = "C"
   strCol(3) = "E"
   strCol(4) = "G"
   
   
   lngLstRow = ActiveSheet.UsedRange.Rows.Count
   
   
   For i = 1 To 4
      For Each rngCell In Range(strCol(i) & "4:" & strCol(i) & lngLstRow)
         With rngCell
            If .Offset(, 1).Value = "" And .Value <= Date Then
               .Resize(, 2).Font.ColorIndex = 3
               .Offset(, 1).Value = Date - .Value
            Else
               .Resize(, 2).Font.ColorIndex = 1
            End If
         End With
      Next rngCell
   Next i
End Sub