Issue with VBA code - removing highlighting from blank cells.

[dougmarkham]

Hi Folks,

I am working on a project to highlight cells red if they exceed certain character lengths

User ID	Name	Address 1	Address 2	Address 3	Address 4	Town / City	Postcode

<tbody>
</tbody>

For instance, I want to use VBA to highlight any cells in the User ID column (col A) if the cells text string > 20 characters; however, if a person then deletes some of the characters so the character string length drops <20, I want the cell's red highlight to disappear. Also, if a person were to clear the contents of a cell that contained >20 (i.e., it's highlighted red already), I want the VBA to remove the red highlight.

I found and adapted some VBA:

Private Sub Worksheet_Change(ByVal Target As RANGE)Dim c As RANGE
Dim LR As Integer
Dim numProbs As Long
Dim sht As Worksheet


Set sht = Worksheets("AddressData")


numProbs = 0
LR = sht.Cells(Rows.Count, "A").End(xlUp).row
For Each c In sht.RANGE("$A$2:$A" & LR).Cells
    If Len(c.Value) > 20 Then
        c.EntireRow.Cells(1).Resize(1, 1).Interior.Color = vbRed
        numProbs = numProbs + 1
    End If
Next
[COLOR=#b22222][B]For Each c In sht.RANGE("$A$2:$A" & LR).Cells[/B][/COLOR]
[COLOR=#0000cd][B]    If c.Value = "" Then[/B][/COLOR]
        c.EntireRow.Cells(1).Resize(1, 1).Interior.Color = xlNone
        numProbs = numProbs + 1
    End If
Next
For Each c In sht.RANGE("$A$2:$A" & LR).Cells
    If Len(c.Value) < 21 Then
        c.EntireRow.Cells(1).Resize(1, 1).Interior.Color = xlNone
        numProbs = numProbs + 1
    End If
Next


If numProbs > 0 Then
    MsgBox "Character limits: Col A (20) - see red cells"
End If

End Sub

The code works, all except the bit that removes highlighting from cells that have their contents cleared (blank cells). Curious thing is that the VBA does its job for cell A2 only. For instance, when you enter a text string of 30 characters, the cell highlights red. When you then clear the contents of cell A2, the red highlight disappears. However, if you do the same process for cell A3 downwards, when you clear the cell contents, the red highlight remains.

Would anybody be able to suggest a way to modify this code (the bit highlighted in red or blue) in order to make it operate in all cells of column A2 downwards?

Kind regards,

Doug.

 

[dougmarkham]

Do you have any data in col A other than A1?

Hi Fluff,

I checked that the cells were truly blank by:
a) Selecting all cells in the ws,
b) Deleting all cells on the ws,
c) Selecting the whole ws, copying,
d) Pasting as values into A1.

Then I pasted the headers back into the ws 'as values' etc.

I purposely put >20 characters into the header in A1: it immediately goes red..Removing the extra characters causes A1 to have its highlighting removed (i.e., it goes white).

Any ideas what's causing this?

Kind regards,

Doug

 

[Fluff]

It's because you don't have any data in col A other than A1.

 

[dougmarkham]

It's because you don't have any data in col A other than A1.

Hi Fluff,

Thanks for finding that solution!
I guess there will always be hundreds of lines of data, so it won't matter.
Curious that it should work that way.

Kind regards,

Doug.

 

[Fluff]

Its because LR is returning 1 so the range is A2:A1

 

[Peter_SSs]

My suggested modification. I'm taking it that you don't want the A1 header coloured even if > 20?

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim c As Range
  Dim numProbs As Long, LR As Long
  
  If Not Intersect(Target, Columns("A")) Is Nothing Then
    Columns("A").Interior.Color = xlNone
    LR = Cells(Rows.Count, "A").End(xlUp).Row + 1
    For Each c In Range("A2:A" & LR)
        If Len(c.Value) > 20 Then
            c.Interior.Color = vbRed
            numProbs = numProbs + 1
        End If
    Next c
    If numProbs > 0 Then MsgBox "Character limits: Col A (20) - see " & numProbs & " red cells"
  End If
End Sub