How to highlight cells with decimals and/or characters less than 3 and more than 6 using vba?

Mahesh Gunda

New Member
Joined
Dec 7, 2016
Messages
5
I'm new to VBA coding and please help me create a VBA script with the following conditions.

  1. Should highlight cells containing decimals.
  2. Should highlight cells with number of characters less than 3 or more than 6.
  3. Should execute from Column G (G1) till the last row last used cell.
My data is alphanumeric or numeric.
I have tried using <code style="margin: 0px; padding: 1px 5px; border: 0px; font-size: 13px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; background-color: rgb(239, 240, 241); white-space: pre-wrap;">characters.count</code> and <code style="margin: 0px; padding: 1px 5px; border: 0px; font-size: 13px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; background-color: rgb(239, 240, 241); white-space: pre-wrap;">Value.count</code> but it didn't work out. Hope it will work with <code style="margin: 0px; padding: 1px 5px; border: 0px; font-size: 13px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; background-color: rgb(239, 240, 241); white-space: pre-wrap;">len</code>, but I'm not sure how to start with.
Please go through table with highlighted cells.
I have tried the below code. Since my data is alphanumeric, characters count doesn't help.


<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">Sub HighlightCells()
Range
(" G1").Select
Do
If ActiveCell.Characters.Count < 3 Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
ActiveCell
.Offset(0, 1).Select 'need to run in every row till the last row last used cell
Loop Until ActiveCell = ""

Range
(" G1").Select
Do
If ActiveCell.Characters.Count > 6 Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
ActiveCell
.Offset(0, 1).Select 'need to run in every row till the last row last used cell
Loop Until ActiveCell = ""
End Sub</code>
ABCDEFGHIJKLM
xxxxxxxxxxxxxxxxxx2500014019250000
xxxxxxxxxxxxxxxxxxa40i25.2m640v85.2
xxxxxxxxxxxxxxxxxx40192500004019250000
xxxxxxxxxxxxxxxxxxi252401.9401940195800000
xxxxxxxxxxxxxxxxxxv4999m640m640m640
xxxxxxxxxxxxxxxxxx60804019m32500054019
xxxxxxxxxxxxxxxxxx2500025000v4999

<colgroup><col width="64" span="13" style="width:48pt"> </colgroup><tbody>
</tbody>

<tbody>
</tbody>
<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;"></code>
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Hello Mahesh Gunda,

This is should work...

Code:
Sub HighlightCells()


    Dim Cell     As Range
    Dim LastCol  As Long
    Dim LastRow  As Long
    Dim Rng      As Range
    Dim Wks	 As Worksheet


	Set Wks = ActiveSheet
        
        Set Cell = Wks.UsedRange.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False, False)


        lastRow = Cell.Row


        Set Cell = Wks.UsedRange.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False, False, False)


        LastCol = Cell.Column


            Set Cell = Wks.Cells(LastRow, LastCol)


            Set Rng = Intersect(Wks.UsedRange, Wks.Range("G1", Cell.Address))


            	For each Cell In Rng.Cells
		    If Len(Cell) < 3 Or Len(Cell) > 6 Then
			With Cell.Interior
			    .Pattern = xlSolid
			    .Color = &HFFFF
                        End With
		    End If'
		    
		    If IsNumeric(Cell) And Instr(1, Cell, ".") > 0 Then
			With Cell.Interior
			    .Pattern = xlSolid
			    .Color = &HFFFF
                        End With
		    End If
		Next Cell


 End Sub
 
Upvote 0
Hi Ross,

The code is running in only one cell. Entire range starting from G1 till last row and last used cell is not being executed.
Can you please look into it.

Thank you for your help.

Regards,
Mahesh Gunda
 
Upvote 0
I made a mistake in the code. This should correct the issue...
Rich (BB code):
Sub HighlightCells()


    Dim Cell     As Range
    Dim LastCol  As Long
    Dim LastRow  As Long
    Dim Rng      As Range
    Dim Wks	 As Worksheet


	Set Wks = ActiveSheet
        
        Set Cell = Wks.UsedRange.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False, False)


        lastRow = Cell.Row


        Set Cell = Wks.UsedRange.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False, False, False)


        LastCol = Cell.Column


            Set Cell = Wks.Cells(LastRow, LastCol)


            Set Rng = Intersect(Wks.UsedRange, Wks.Range("$G$1" & Cell.Address))


            	For each Cell In Rng.Cells
		    If Len(Cell) < 3 Or Len(Cell) > 6 Then
			With Cell.Interior
			    .Pattern = xlSolid
			    .Color = &HFFFF
                        End With
		    End If'
		    
		    If IsNumeric(Cell) And Instr(1, Cell, ".") > 0 Then
			With Cell.Interior
			    .Pattern = xlSolid
			    .Color = &HFFFF
                        End With
		    End If
		Next Cell


 End Sub
 
Upvote 0
Try this code:
Code:
Sub Test()
    Application.ScreenUpdating = False
    LastRow = Rows(ActiveSheet.UsedRange.Row + _
        ActiveSheet.UsedRange.Rows.Count - 1).Row
    LastCol = Columns(ActiveSheet.UsedRange.Column + _
        ActiveSheet.UsedRange.Columns.Count - 1).Column
    For Each cll In Range(Cells(1, 7), Cells(LastRow, LastCol))
        s = cll.Value
        l = Len(s)
        If ((l > 0) And (l < 3)) Or (l > 6) Or (s Like "*#.#*") _
            Then cll.Interior.Color = vbRed
    Next cll
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
I made a mistake in the code. This should correct the issue...
Rich (BB code):
Sub HighlightCells()


    Dim Cell     As Range
    Dim LastCol  As Long
    Dim LastRow  As Long
    Dim Rng      As Range
    Dim Wks     As Worksheet


    Set Wks = ActiveSheet
        
        Set Cell = Wks.UsedRange.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False, False)


        lastRow = Cell.Row


        Set Cell = Wks.UsedRange.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False, False, False)


        LastCol = Cell.Column


            Set Cell = Wks.Cells(LastRow, LastCol)


            Set Rng = Intersect(Wks.UsedRange, Wks.Range("$G$1" & Cell.Address))


                For each Cell In Rng.Cells
            If Len(Cell) < 3 Or Len(Cell) > 6 Then
            With Cell.Interior
                .Pattern = xlSolid
                .Color = &HFFFF
                        End With
            End If'
            
            If IsNumeric(Cell) And Instr(1, Cell, ".") > 0 Then
            With Cell.Interior
                .Pattern = xlSolid
                .Color = &HFFFF
                        End With
            End If
        Next Cell


 End Sub




Its still not working Ross.
I think there is an issue with the range only.
Please look into it.

Thanks.
 
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,342
Members
448,570
Latest member
rik81h

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top