Coloring Three Group Numbers

The goal is to highlight numbers based the associated groups. For instance, all numbers in the "B" group are colored red, C is colored green and D is colored blue. Note: you may have to change the color of the number from black to white or another color in order for it to be visible.

The groups are located in the Update sheet while the actual coloring occurs in the Numbers sheet. Prefereably, let me select the numbers to color. For instance, Group if B3:F1628 is selected then only numbers in B:F are colored and none other. In this instance, the coloring occurs based where the numbers is in the Update sheet.

The first line is provided as a sample of the intended result in any chosen cell groups. Also included is a script that accomplishes the task but it is too slow when run on multiple cells. If you use the enclosed script please make it faster. Also, it was programmed for an older version of excel in case that helps any.
Group3Coloring.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.

Ejgil HedegaardCommented:
Use conditional formatting, that is fast.
The 3 numbercolumns on Update are named Group1 for B4:B25, Group2 for C4:C25 and Group3 for D4:D25.
The conditional formula for first colour is =ISERROR(MATCH(B3,Group1,0))=FALSE
Similar for the other 2.
See attached file, not sure colours are excactly match, downsized to 30 rows, copy B3 to your actual file and change the conditional range to column G and row 142509
Group3Coloring-small-sample.xlsx
0
Pedrov664Author Commented:
OK, just a heads up. I did not write the code and am not a programmer so it is best if you write the code that runs faster much faster and let me run it on a large group to see how much faster it is.
0
redmondbCommented:
Hi, Pedro.

Please try the code below. (For the moment, it  does all used rows in "Numbers" (excluding rows 1 & 2) for columns B to G.)

Regards,
Brian.
Option Explicit

Option Base 0

Sub Colour_Numbers()
Dim i           As Long
Dim j           As Long
Dim xLast_Row   As Long
Dim xArray1     As Variant
Dim xArray2     As Variant
Dim xArray3     As Variant
Dim Xall        As Variant
Dim StartTime   As Variant
Dim xNumbers    As Worksheet

StartTime = Timer

Set xNumbers = Sheets("Numbers")

xLast_Row = xNumbers.UsedRange.Cells(1, 1).Row + xNumbers.UsedRange.Rows.Count - 1
If xLast_Row < 3 Then
    MsgBox ("No data found in the ""Numbers"" Sheet - run cancelled.")
    Exit Sub
End If

xArray1 = [Update!B4:B25]
xArray2 = [Update!C4:C25]
xArray3 = [Update!D4:D25]

Application.ScreenUpdating = False

    'Set default to first category...
    xNumbers.Range("B3:G" & xLast_Row).Interior.ColorIndex = 3
    xNumbers.Range("B3:G" & xLast_Row).Font.ColorIndex = 2
    xNumbers.Range("B3:G" & xLast_Row).Font.Bold = True
    
    Xall = xNumbers.Range("B1:G" & xLast_Row)
        
    For i = 3 To xLast_Row
        For j = 1 To 6
            Select Case Xall(i, j)
                Case xArray1(1, 1), xArray1(2, 1), xArray1(3, 1), xArray1(4, 1), xArray1(5, 1), xArray1(6, 1), xArray1(7, 1), xArray1(8, 1), xArray1(9, 1), xArray1(10, 1) _
                    , xArray1(11, 1), xArray1(12, 1), xArray1(13, 1), xArray1(14, 1), xArray1(15, 1), xArray1(16, 1), xArray1(17, 1), xArray1(18, 1), xArray1(19, 1), xArray1(20, 1) _
                    , xArray1(21, 1), xArray1(22, 1)
                    ' Nothing to do as this is the default.
                Case xArray2(1, 1), xArray2(2, 1), xArray2(3, 1), xArray2(4, 1), xArray2(5, 1), xArray2(6, 1), xArray2(7, 1), xArray2(8, 1), xArray2(9, 1), xArray2(10, 1) _
                    , xArray2(11, 1), xArray2(12, 1), xArray2(13, 1), xArray2(14, 1), xArray2(15, 1), xArray2(16, 1), xArray2(17, 1), xArray2(18, 1), xArray2(19, 1), xArray2(20, 1) _
                    , xArray2(21, 1), xArray2(22, 1)
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = 4
                    xNumbers.Cells(i, j + 1).Font.ColorIndex = 1
                Case xArray3(1, 1), xArray3(2, 1), xArray3(3, 1), xArray3(4, 1), xArray3(5, 1), xArray3(6, 1), xArray3(7, 1), xArray3(8, 1), xArray3(9, 1), xArray3(10, 1) _
                    , xArray3(11, 1), xArray3(12, 1), xArray3(13, 1), xArray3(14, 1), xArray3(15, 1), xArray3(16, 1), xArray3(17, 1), xArray3(18, 1), xArray3(19, 1), xArray3(20, 1) _
                    , xArray3(21, 1), xArray3(22, 1)
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = 14
                Case Else
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = xlNone
                    xNumbers.Cells(i, j + 1).Font.ColorIndex = 1
                    xNumbers.Cells(i, j + 1).Font.Bold = False
            End Select
        Next
    Next
    
Application.ScreenUpdating = True

Debug.Print "Processed " & i - 2 & " rows of " & xLast_Row & " - " & Format(Timer - StartTime, "000") & " seconds."
MsgBox ("Processed " & i - 2 & " rows of " & xLast_Row & " - " & Format(Timer - StartTime, "000") & " seconds.")

End Sub

Open in new window

0
Fundamentals of JavaScript

Learn the fundamentals of the popular programming language JavaScript so that you can explore the realm of web development.

Pedrov664Author Commented:
Redmond,

Excellen work, as usual. However, please allow me to choose which cells to color since I may not want or need all of them.

Best Regards,
Pedro
0
redmondbCommented:
Pedro,

OK, the following uses the current selection. It handles everything from single cells to multiple ranges.
Option Explicit

Option Base 0

Sub Colour_Groups_II()
Dim i           As Long
Dim j           As Long
Dim k           As Long
Dim xRow_Offset As Long
Dim xCol_Offset As Long
Dim xCells      As Long
Dim xAll        As Variant
Dim xHold       As Variant
Dim StartTime   As Variant
Dim xArea       As Variant
Dim xArray1     As Variant
Dim xArray2     As Variant
Dim xArray3     As Variant
Dim xNumbers    As Worksheet

StartTime = Timer

Set xNumbers = Sheets("Numbers")


xArray1 = [Update!B4:B25]
xArray2 = [Update!C4:C25]
xArray3 = [Update!D4:D25]

Application.ScreenUpdating = False

    For k = 1 To Selection.Areas.Count
        Set xArea = Selection.Areas(k)
    
    '   Set default to first category...
        xArea.Interior.ColorIndex = 3
        xArea.Font.ColorIndex = 2
        xArea.Font.Bold = True
        
        xAll = xArea
        
        xRow_Offset = xArea.Range("A1").Row - 1
        xCol_Offset = xArea.Range("A1").Column - 1
    
        For i = xArea.Range("A1").Row To xArea.Rows(xArea.Rows.Count).Row
            For j = xArea.Range("A1").Column To xArea.Columns(xArea.Columns.Count).Column
                xCells = xCells + 1
                If VarType(xAll) > 8192 Then xHold = xAll(i - xRow_Offset, j - xCol_Offset) Else xHold = xAll
                If IsEmpty(xHold) Then xHold = "Case Else"
                Select Case xHold
                    Case xArray1(1, 1), xArray1(2, 1), xArray1(3, 1), xArray1(4, 1), xArray1(5, 1), xArray1(6, 1), xArray1(7, 1), xArray1(8, 1), xArray1(9, 1), xArray1(10, 1) _
                        , xArray1(11, 1), xArray1(12, 1), xArray1(13, 1), xArray1(14, 1), xArray1(15, 1), xArray1(16, 1), xArray1(17, 1), xArray1(18, 1), xArray1(19, 1), xArray1(20, 1) _
                        , xArray1(21, 1), xArray1(22, 1)
                        ' Nothing to do as this is the default.
                    Case xArray2(1, 1), xArray2(2, 1), xArray2(3, 1), xArray2(4, 1), xArray2(5, 1), xArray2(6, 1), xArray2(7, 1), xArray2(8, 1), xArray2(9, 1), xArray2(10, 1) _
                        , xArray2(11, 1), xArray2(12, 1), xArray2(13, 1), xArray2(14, 1), xArray2(15, 1), xArray2(16, 1), xArray2(17, 1), xArray2(18, 1), xArray2(19, 1), xArray2(20, 1) _
                        , xArray2(21, 1), xArray2(22, 1)
                        xNumbers.Cells(i, j).Interior.ColorIndex = 4
                        xNumbers.Cells(i, j).Font.ColorIndex = 1
                    Case xArray3(1, 1), xArray3(2, 1), xArray3(3, 1), xArray3(4, 1), xArray3(5, 1), xArray3(6, 1), xArray3(7, 1), xArray3(8, 1), xArray3(9, 1), xArray3(10, 1) _
                        , xArray3(11, 1), xArray3(12, 1), xArray3(13, 1), xArray3(14, 1), xArray3(15, 1), xArray3(16, 1), xArray3(17, 1), xArray3(18, 1), xArray3(19, 1), xArray3(20, 1) _
                        , xArray3(21, 1), xArray3(22, 1)
                        xNumbers.Cells(i, j).Interior.ColorIndex = 14
                    Case Else
                        xNumbers.Cells(i, j).Interior.ColorIndex = xlNone
                        xNumbers.Cells(i, j).Font.ColorIndex = 1
                        xNumbers.Cells(i, j).Font.Bold = False
                End Select
        Next
    Next
    
Next
    
Application.ScreenUpdating = True

Debug.Print "Completed " & Format(xCells, "#,##0") & " cells in " & Format(Timer - StartTime, "000") & " seconds."
MsgBox "Completed " & Format(xCells, "#,##0") & " cells in " & Format(Timer - StartTime, "000") & " seconds."

End Sub

Open in new window

Regards,
Brian.
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:
I would like to run both scripts from the same excel file. I noticed on top the following:

Option Explicit

Option Base 0

does not stay within the script. There is a line that separates the above from the rest of the script will this affect how the script works in any way?

Other than that Great Job!

P.S. I ran both scripts from the same xlsm file and they seem to work fine. I'd just like to get your approval since you're the programmer and know what effect, if any, this has.
0
redmondbCommented:
Pedro,

They may only appear at the start of a Module (and there may only be one of each.)  

"Option Explicit" tells Excel to check that all variables have been Dim'ed. While not compulsory, it's hugely valuable. For example, it will catch misspellings (such as "W0RK" instead of "WORK"). You should always use it - in fact one of the settings is "Require Variable Declaration" which will automatically add the line to any new Module.

"Option Base 0" specifies that the first element of standard arrays is zero. It's the default, but I always specify it when I'm using an arrary (it's a warning for someone else who may subsequently want to add an "Option Base 1".) In this case, it's doubly unnecessary - the macro no longer uses standard arrays.

So, yes, the two Macros can happily live in the same Module - just add an "Option Explicit" before the first one.

Regards,
Brian.
0
Pedrov664Author Commented:
At this point, I think you are doing such an excellent job that words simply cannot express ...
0
redmondbCommented:
Thanks! Glad to help, Pedro!
0
Pedrov664Author Commented:
Redmond:

Just a heads up. Since you did such a great job here you may want take a look at my recent post. ID28229695.

I think the script you posted here just needs to be tweeked a little and it would do the trick.

Best Regards,
Pedro
0
redmondbCommented:
Thanks, Pedro. However, you're in good hands there, so I won't interfere.

Regards,
Brian.
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.