Sub Test()
Dim Rng As Range, a, v, r&
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
a = Rng.Value
For r = 1 To UBound(a)
v = a(r, 1)
a(r, 1) = Empty
If VarType(v) = vbString Then
If Len(v) > 0 Then
a(r, 1) = "=IF(MIN(RC[-9]:RC[-7])<=TODAY(),""NonCompliant"",""Compliant"")"
End If
End If
Next
Rng.Columns("O").Value = a
End Sub
' Preserve old contents of Column O
Sub Test1()
Dim Rng As Range, a, b, v, r&
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
a = Rng.Value
b = Rng.Columns("O").Value
For r = 1 To UBound(a)
v = a(r, 1)
If VarType(v) = vbString Then
If Len(v) > 0 Then
b(r, 1) = "=IF(MIN(RC[-9]:RC[-7])<=TODAY(),""NonCompliant"",""Compliant"")"
End If
End If
Next
Rng.Columns("O").Value = b
End Sub
ADVERTISEMENT
ADVERTISEMENT
Sub Test2()
Dim Rng As Range, a, v, r&
' Set range of values in Column A
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
' Copy Rng values to a() to speed up processing
a = Rng.Value
' Analyze each value of a(), empty it or put formula into it
For r = 1 To UBound(a)
v = a(r, 1)
a(r, 1) = Empty
If VarType(v) = vbString Then
If Len(v) > 0 Then
a(r, 1) = "=IF(MIN(RC[-9]:RC[-7])<=TODAY(),""NonCompliant"",""Compliant"")"
End If
End If
Next
' Put formulas and CFs to the destination ranges
With Rng
' Copy a() to the destination column O
.Columns("O").Value = a
' Set CFs to F:H range
SetCF .Range("F:H").Resize(UBound(a) - 6).Offset(6)
End With
End Sub
Private Sub SetCF(Rng As Range)
' Conditional formulas in R1C1 format, change to suit
Const Fm1$ = "=IF(ISTEXT(RC1),RC <= TODAY())"
Const Fm2$ = "=IF(ISTEXT(RC1),AND(RC > TODAY(),RC < TODAY()+7))"
Const Fm3$ = "=IF(ISTEXT(RC1),AND(RC > TODAY(),RC < TODAY()+30))"
With Rng
With .FormatConditions
' Delete CFs
.Delete
' Add CF #1
With .Add(Type:=xlExpression, Formula1:=Fm1)
.Borders.LineStyle = xlContinuous
.Interior.ColorIndex = 35 ' <-- Change to suit
End With
' Add CF #2
With .Add(Type:=xlExpression, Formula1:=Fm2)
.Borders.LineStyle = xlContinuous
.Interior.ColorIndex = 36 ' <-- Change to suit
End With
' Add CF #3
With .Add(Type:=xlExpression, Formula1:=Fm3)
.Borders.LineStyle = xlContinuous
.Interior.ColorIndex = 40 ' <-- Change to suit
End With
End With
End With
End Sub
Const Fm1$ = "=IF(ISTEXT(RC1),RC6 <= TODAY())"
Const Fm2$ = "=IF(ISTEXT(RC1),AND(RC6 > TODAY(),RC6 < TODAY()+7))"
Const Fm3$ = "=IF(ISTEXT(RC1),AND(RC6 > TODAY(),RC6 < TODAY()+30))"