How to change font colour on Variant excel VBA? - excel

Question

I have some code that takes a cell value such as <0.2 and discards the 'less than' symbol and returns half the numeric portion e.g. 0.1
This works well but I want to indicate the cells that have been changed by making the font colour red.
I can't get the formatting applied. I have tried a few variations on the code below but get a run-time error 424 object required, on the formatting line. MyVar = MyVar.Font.ColorIndex = 3
Sub RemoveLessThanSpedUp()
'
'
'Values with Red Text were reported as less than the method detection limit and are shown here as one-half the detection limit
'
Dim r As Range
Dim Datarange As Variant
Dim Irow As Integer
Dim MaxRows As Long
Dim Icol As Integer
Dim MaxCols As Long
Dim MyVar As Variant
Datarange = Range("A1").CurrentRegion.Value
MaxRows = Range("A1").CurrentRegion.Rows.Count
MaxCols = Range("A1").CurrentRegion.Columns.Count
For Irow = 1 To MaxRows
For Icol = 1 To MaxCols
MyVar = Datarange(Irow, Icol)
If Left(MyVar, 1) = "<" Then
MyVar = (Right(MyVar, Len(MyVar) - 1)) / 2
MyVar = MyVar.Characters.ColorIndex = 3
'MyVar.Font.ColorIndex = 3
Datarange(Irow, Icol) = MyVar
End If
Next Icol
Next Irow
Range("A1").CurrentRegion = Datarange
End Sub```

Answer 1

Try the next adapted code, please. Your code uses an array, which is not bad in terms of speed, but it does not handle ranges which have a font property. Coloring many cells may take a lot of time. I will build an array to be filled with the modified cells address, which will be dropped on the first column after the existing one:
Sub RemoveLessThanSpedUp()
Dim r As Range, Datarange As Variant, Irow As Integer
Dim MaxCols As Long, MyVar As Variant, MaxRows As Long, Icol As Long
Dim sh As Worksheet, i As Long, arrEr, k As Long
Set sh = ActiveSheet 'use here what you need
MaxRows = sh.Range("A1").CurrentRegion.Rows.Count
MaxCols = sh.Range("A1").CurrentRegion.Columns.Count
If sh.Cells(1, MaxCols).Value = "Errors" Then
sh.Cells(1, MaxCols).EntireColumn.Clear
MaxCols = MaxCols - 1
End If
Datarange = sh.Range("A1").CurrentRegion.Value
ReDim arrEr(MaxRows * MaxCols)
For Irow = 1 To MaxRows
For Icol = 1 To MaxCols
i = i + 1
MyVar = Datarange(Irow, Icol)
If Left(MyVar, 1) = "<" Then
MyVar = (Right(MyVar, Len(MyVar) - 1)) / 2
arrEr(k) = sh.Cells(Irow, Icol).Address(0, 0): k = k + 1
Datarange(Irow, Icol) = MyVar
End If
Next Icol
Next Irow
If k > 0 Then
ReDim Preserve arrEr(k - 1)
sh.Range("A1").CurrentRegion = Datarange
With sh.Cells(2, MaxCols + 1)
.Offset(-1).Value = "Errors"
.Resize(k, 1).Value = Application.Transpose(arrEr)
End With
Else
MsgBox "Nothing to be corrected..."
End If
End Sub