VBA: Specific number in a serie-of-numbers in a cell equals a color

Infine

Board Regular
Joined
Oct 16, 2019
Messages
93
Office Version
  1. 365
Platform
  1. Windows
Hello,

If I have numbers in a cell "1294392393", I want the 4th from the right side (the thousand number), I want a "color/border" on the whole columns.

For instance:

"1294392393" = 12943[9]393 ----- the nr "9" shall make a color blue on the whole column.
In a row below the "12943" = 1[2]943 ----- The nr "2" shall make a color orange on the whole column.

"1000" = [1]000 ---- The nr "1" shall have the color Red on the whole column.

And last example:

"14751565152512" = 1475156515[2]512 ---- the nr 2 shall have orange on the whole column.



I found this code in this forum from someone else topic:

Code:
Sub Controll_datas()
On Error Resume Next

Dim c As Range

For Each c In Range("C2", Range("C" & Rows.Count).End(xlUp))
    If IsNumeric(Mid(c, 3, 1)) Then
        c = "TGMS"
    End If
Next c

End Sub

This takes ANY number, I want specific number, and instead of c= "TGMS" I want to make for each nr a color.
So every number:
1 = blue
2 = orange
3 = etc etc. until 9.


How should I code this? I can't figure out because I want specific number, not any... I want to If IsNumeric(Right(c, 4, 1) = 1) Then for nr 1. but this doesn't work...
I know coding on PHP, so excel coding is a bit different where I need to relearn some.
 
Do you have any blank cells in col C?
Also do any cells in col C anything other than numbers?
 
Upvote 0

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Yes ofcourse I have blank cells. And it isn't atm but it could be. Should it matter? I mean just take the 4th from the right going left and if its = 1 then blue color. If it's = 2 then another color etc

I hope I make sense.
 
Upvote 0
Should it matter?
Yes because if the cell is blank you cant get the 4the character from the right ;)

How about
Code:
Sub Infine()
    Dim Cl As Range

    For Each Cl In Range("C2", Range("C" & Rows.Count).End(xlUp))
        If Not Cl.Value = "" And IsNumeric(Left(Right(Cl, 4), 1)) Then
            Intersect(Cl.EntireRow, Range("A:D")).Interior.ColorIndex = Choose(Left(Right(Cl, 4), 1) + 1, 3, 5, 9, 11, 15, 23, 35, 44, 56, 49)
        End If
    Next Cl
End Sub
 
Upvote 0
It's not working properly :/ I typed different random numbers and it doesn't do what it should do.

I get "200" as a color. I also get some numbers no color.
 
Upvote 0
In that case can you please post some accurate samples of your data. Explaining exactly what you want for each.
 
Last edited:
Upvote 0
So if I try writing:
11111111
22222222
3333333 etc, it works.

When I write

100
200
300
400

it still gives them colors.


So I want the VBA function to ONLY go 4 numbers to the left (starting from the right side) and then if it is = 1 I want it to make a color.
I am okay with if each number has it own IF to decrease the chances of this function to bug.

So maybe it will be easier if we make a function saying this:

If the number in a cell, starting from right, going 4 steps left is equal to 1, then
Put red
End If

Possible? Then I can put a new color for "2" with a new Else If, etc
 
Last edited:
Upvote 0
How about
Code:
Sub Infine()
    Dim Cl As Range

    For Each Cl In Range("C2", Range("C" & Rows.Count).End(xlUp))
        If Not Cl.Value = "" And IsNumeric(Right(Left(Cl, Len(Cl) - 3), 1)) Then
            Intersect(Cl.EntireRow, Range("A:D")).Interior.ColorIndex = Choose(Right(Left(Cl, Len(Cl) - 3), 1) + 1, 3, 5, 9, 11, 15, 23, 35, 44, 56, 49)
        End If
    Next Cl
End Sub
 
Upvote 0
It works but it is too many bugs if you test it in different scenarios.

These values in C makes it bug for instance:

Code:
1231312
1
21
21
1
34
2123123
12313123
141412412


So I think to minimize the bugs do you know the formula for:
Code:
If the number in a cell, starting from right, going 4 steps left is equal to 1, then 
Put red
End If


Then I can try something else. I need it to be 100% reliable. I don't understand the code you have written that is why I can't test for myself different ways. :/
 
Upvote 0
How about
Code:
Sub Infine()
    Dim Cl As Range

    For Each Cl In Range("C2", Range("C" & Rows.Count).End(xlUp))
        If Len(Cl.Value) > 3 Then
            If IsNumeric(Right(Left(Cl, Len(Cl) - 3), 1)) Then
                Intersect(Cl.EntireRow, Range("A:D")).Interior.ColorIndex = Choose(Right(Left(Cl, Len(Cl) - 3), 1) + 1, 3, 5, 9, 11, 15, 23, 35, 44, 56, 49)
            Else
                Intersect(Cl.EntireRow, Range("A:D")).Interior.ColorIndex = xlNone
            End If
        Else
            Intersect(Cl.EntireRow, Range("A:D")).Interior.ColorIndex = xlNone
        End If
    Next Cl
End Sub
This will also clear any colour on rows that don't meet the criteria
 
Upvote 0
Thanks man. I will try this, I just noticed if you write "=rand()" sometimes it wont color it... Even if it should.

But I will try this and see if it works, bugfree.

Meanwhile, if possible; Do you know the IF sats for a more simple way...

If column is a number and the 4th number starting to the right is = 1. Then put Red color.

1000 = red color
21000 = red color.

So basically the same, but only setting for nr 1. I want to see how that looks like for learning purposes so I can understand how your code works.
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,287
Members
448,562
Latest member
Flashbond

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