Conditional Criteria with colored cells

[fher9728]

Hi community,

I've been doing some work in a table, and this table works a lot with dates, so the thing I wanted to do is that dates that are 15 days after todays date they'll be highlight in color yellow, I did that with no problems with conditional formatting, but the problem that I have is in the next step, I want that the cells that are highlight in yellow shows a Status that says "Vencida" and the cells that aren't highlight show status "Vigente", but I want to do this full with Vba, but without a vba function because I dont want to use formulas because the range of data is so extensive that the Workbook will be so big and I need to remain a fast and light workbook, I'll show the table:

The thing I want to do is like a conditional that if cells with range G are highlight with yellow color the status in range M shows me "Vencida" else show "Vigente",
I've been trying to do that but it only shows me Vigente, but the status doesn't change to Vencida, this is the code:

Sub COUNT_HIGHLIGHTS()
'
' COUNT_HIGHLIGHTS
'


'Defining variables
Dim LastRow As Long, Count As String
Dim celdaOrigen As Range, rango As Range


'Getting a number value for the number of rows in the table (as this can vary on table size)
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "G").End(xlUp).Row


'For loop to loop through rows
For i = 2 To LastRow
'Count is the number of cells in the row which are highlighted
Count = "VIGENTE"
'For loop for cells within the row (My table always has 36 cells)
For J = 2 To LastRow
'If statement to check if cell is highlighted
If Cells(i, 7).Interior.Color = ActiveSheet.Range("U1").Interior.Color Then
'Add +1 to count ever time a highlighted cell is found
Count = "VENCIDA"
End If
Next J
'find cell at the end of the row and add the count
Cells(i, 13).Select
Selection.Value = Count
Next i
End Sub

SECOND POINT

In column H,J,K,L I have an vba code which if I put any text or value in Column B range it will throw me automatically todays date, like registration date in the table, the problem that I have is that I need to copy paste data from another table and if do that it doesnt shows me automatically the registration date, I want to copy and paste the data un column B and automatically shows me the date in column G, also I want to let me undo the action because when I modify something in this two columns it doesn't let me undo any action:

the vba code for this is :

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Target, Range("B:B")) Is Nothing Then

Range("H" & Target.Row) = Date

Range("I" & Target.Row) = Format(Now, "hh:mm")

End If

If Not Application.Intersect(Target, Range("J:J")) Is Nothing Then

Range("K" & Target.Row) = Date + Target.Value

End If

If Not Application.Intersect(Target, Range("K:K")) Is Nothing Then

Range("L" & Target.Row) = Target.Value

End If
End Sub

Pleaaase I need help, thankyou

 

[fher9728]

Ok, how about

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Cl As Range
   If Not Application.Intersect(Target, Range("B:B")) Is Nothing Then
      For Each Cl In Intersect(Target, Range("B:B"))
         Cl.Offset(, 6) = Date
         Cl.Offset(, 7) = Format(Now, "hh:mm")
      Next Cl
   ElseIf Not Application.Intersect(Target, Range("J:J")) Is Nothing Then
      Range("K" & Target.Row) = Date + Target.Value
   ElseIf Not Application.Intersect(Target, Range("K:K")) Is Nothing Then
      Range("L" & Target.Row) = Target.Value
   End If
End Sub

Works perfect!!

Ok, how about

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Cl As Range
   If Not Application.Intersect(Target, Range("B:B")) Is Nothing Then
      For Each Cl In Intersect(Target, Range("B:B"))
         Cl.Offset(, 6) = Date
         Cl.Offset(, 7) = Format(Now, "hh:mm")
      Next Cl
   ElseIf Not Application.Intersect(Target, Range("J:J")) Is Nothing Then
      Range("K" & Target.Row) = Date + Target.Value
   ElseIf Not Application.Intersect(Target, Range("K:K")) Is Nothing Then
      Range("L" & Target.Row) = Target.Value
   End If
End Sub

thanks for your help

 

[Fluff]

You're welcome & thanks for the feedback