VBA Code Add Condition

hrayani

Well-known Member
Joined
Jul 23, 2010
Messages
824
Office Version
2016
Platform
Windows
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.


Code:
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
 

Some videos you may like

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,604
Office Version
365
Platform
Windows
Try
Code:
    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

Well-known Member
Joined
Jul 23, 2010
Messages
824
Office Version
2016
Platform
Windows
Hi Fluff,

Thanks for the solution. Working PERFECT

Kind Regards :)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,604
Office Version
365
Platform
Windows
You're welcome & thanks for the feedback
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
5,480
Office Version
2013
Platform
Windows
Hi,
try

Code:
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

Well-known Member
Joined
Jul 23, 2010
Messages
824
Office Version
2016
Platform
Windows
Thanks Dave

Will try that too
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
5,480
Office Version
2013
Platform
Windows
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

Well-known Member
Joined
Jul 23, 2010
Messages
824
Office Version
2016
Platform
Windows
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
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
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

Well-known Member
Joined
Jul 23, 2010
Messages
824
Office Version
2016
Platform
Windows
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

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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,604
Office Version
365
Platform
Windows
How about
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
            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
 

Forum statistics

Threads
1,089,452
Messages
5,408,312
Members
403,196
Latest member
annph

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top