Edit coloring based on B3:G3 selection

The attached file is the one to be edited or you can write your own script.

I highlighted B3:F3 and it colors the number in G3 even though it is not highlighted. The idea is to search for and color only the selected columns since I did not select G3 I do not want that number colored in when it is found. I hope that clarifies things.

The idea is to automatically only color the selected numbers.
Copy-of-GroupColoring.xlsm
Pedrov664Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

NorieData ProcessorCommented:
Doesn't happen when I run the code.
0
Pedrov664Author Commented:
What doesn't happen?

When you run the code it should prompt you to make a selection. Select cells B3:G5, for example and it should color cells that match numbers in B3:G3.
0
NorieData ProcessorCommented:
You said select B3:F3, not B3:G3, so that's what I did.

I thought the problem was that G3 was being coloured when ''I did not select G3'?
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

Pedrov664Author Commented:
The idea is that I would like to 'change' the script. So that it does NOT color G3 when that position is not chosen. Currently it colors it even though it is not part of the selection.
0
byundtMechanical EngineerCommented:
I agree with imnorie: the code is working for me just the way that you say it ought to. In other words, if I select B3:F3 in response to the InputBox, then cell G3 does not get colored.
0
Pedrov664Author Commented:
While it is true that Cell G3 does not get colored, please note that you must choose far enough down to select the 'number' in cell G3 to see the result. Therefore, select down to cell B3:F18 and you will see that number 14 gets colored which is the number contained in cell G3.

The point of this is that if the selection does not include G3 then that number should not get colored in. Therefore, a modification of the original script is needed to accomplish this.
0
byundtMechanical EngineerCommented:
As written, your macro puts the values in cells B3:G3 into a Dictionary. This range is fixed in the code. The macro then asks for the user to select some cells. Any value in the selected range that is also in the Dictionary will be colored.

If you want something different to happen, you will need to describe exactly how it should work. Based on your latest Comment, it is not clear what cells should go in the Dictionary.
0
byundtMechanical EngineerCommented:
I revised your macro so it only puts cells from B3:G3 into the Dictionary if they are in the same column as the user-selected range. If the user selects B3:F18, then cell F17 (which contains a 14, the same as G3) will not be colored.
Sub ApplyColour()

Dim x As Long
Dim d As Object
Dim BaseRange As Range
Dim r As Range, c As Range
Dim BaseColours

Set d = CreateObject("Scripting.Dictionary")
BaseColours = Array(3, 4, 14, 12, 13, 11)

On Error GoTo err_01
Set c = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8)
On Error GoTo 0
If c Is Nothing Then Exit Sub

Set BaseRange = Intersect(c.EntireColumn, Range("B3:G3"))
For Each r In BaseRange.Cells
    If Len(r) > 0 Then
        If Not d.Exists(r.Value) Then
            x = x + 1
            d.Add r.Value, x
        End If
    End If
Next r

Application.ScreenUpdating = False

c.Interior.ColorIndex = xlNone
c.Font.ColorIndex = 1
c.Font.Bold = False

For Each r In c.Cells
    If d.Exists(r.Value) Then
        r.Interior.ColorIndex = BaseColours(d.Item(r.Value) - 1)
        r.Font.ColorIndex = 2
        r.Font.Bold = True
    End If
Next r

err_01:

End Sub

Open in new window

0
SteveCommented:
Could you try the following... it allows for selecting the first cells too.

So first select 5 or 6 cells in Row3 or other as required... then the next range for adding colour.

Option Explicit

Sub ApplyColour()


Dim x As Long
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")

Dim r As Range, c As Range

Dim BaseColours
BaseColours = Array(3, 4, 14, 12, 13, 11)

Dim BaseRange As Range
On Error GoTo err_01
Set BaseRange = Application.InputBox(Prompt:="Please Select Range of first numbers", Title:="Range Select", Type:=8)
On Error GoTo 0
For Each r In BaseRange.Cells
    If Len(r) > 0 Then
        If Not d.Exists(r.Value) Then
            x = x + 1
            d.Add r.Value, x
        End If
    End If
Next r
On Error GoTo err_01
Set c = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8)
On Error GoTo 0
Application.ScreenUpdating = False

c.Interior.ColorIndex = xlNone
c.Font.ColorIndex = 1
c.Font.Bold = False

For Each r In c.Cells
    If d.Exists(r.Value) Then
        r.Interior.ColorIndex = BaseColours(d.Item(r.Value) - 1)
        r.Font.ColorIndex = 2
        r.Font.Bold = True
    End If
Next r
err_01:
Application.ScreenUpdating = True

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Pedrov664Author Commented:
Byundt and The_Barman,

I must say both of you did an excellent job.

The_Barman, you actually went above and beyond the call of duty. You deserve a medal of honor for actually making the job of clearing cells after they're used so much easier, and I specially like the fact that I can select a different set of cells in the process.

P.S. I do hope you're both satisfied about splitting the points in this case. If there is another viable solution, I am all ears. Again, Thank you for a job well done.
0
SteveCommented:
You are welcome

Please do not worry about the splitting of points...
I am always far happier with the words of thanks and knowing you have a good answer.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.