• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 291
  • Last Modified:

Coloring Six Group numbers

The goal is to highlight numbers in the Numbers sheet based on the numbers in the Update sheet F4:K13.  For instance, all numbers in F found in Numbers group would all be colored the same, all numbers in Update sheet column G found in Numbers sheet are colored and so forth. Using different colors for each column in the Update sheet.

The attached sheet has a code that performs the intended purpose but runs way too slow. You can either write your own code or update this code to work faster.
numberRangeColoring.xlsm
0
Pedrov664
Asked:
Pedrov664
  • 5
  • 5
1 Solution
 
cupCommented:
Sounds like an school assignment: what is your problem - understanding it, rewriting it or updating it?
0
 
Pedrov664Author Commented:
None of the above. I am not a programmer and did not write the code you see. I just need this code that runs faster because I would like to run it a large amount of data without having to wait as long as I do now for it to finish. If you have to rewrite the code from scratch so be it.
0
 
redmondbCommented:
Hi, Pedro.

Please see the code below. Couple of points...
(1) The sheet with 142,508 rows takes 43 seconds. That OK?
(2) I changed your table...
       - It's now F4:K13.
       - I've made the first column consistent with the rest, so it's 0 to 9.

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 xArray4     As Variant
Dim xArray5     As Variant
Dim xArray6     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!F4:F13]  'Highlight values that match these cells in red 1-9
xArray2 = [Update!G4:G13]  'Highlight values that match these cells in Green 10-19
xArray3 = [Update!H4:H13]  'Highlight values that match these cells in Dark Cyan 20-29
xArray4 = [Update!I4:I13]  'Highlight values that match these cells in Olive 30-39
xArray5 = [Update!J4:J13]  'Highlight values that match these cells in Dark Magenta 40-49
xArray6 = [Update!K4:K13]  'Highlight values that match these cells in Magenta 50-56

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)
                    ' 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)
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = 4
                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)
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = 14
                Case xArray4(1, 1), xArray4(2, 1), xArray4(3, 1), xArray4(4, 1), xArray4(5, 1), xArray4(6, 1), xArray4(7, 1), xArray4(8, 1), xArray4(9, 1), xArray4(10, 1)
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = 12
                Case xArray5(1, 1), xArray5(2, 1), xArray5(3, 1), xArray5(4, 1), xArray5(5, 1), xArray5(6, 1), xArray5(7, 1), xArray5(8, 1), xArray5(9, 1), xArray5(10, 1)
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = 13
                Case xArray6(1, 1), xArray6(2, 1), xArray6(3, 1), xArray6(4, 1), xArray6(5, 1), xArray6(6, 1), xArray6(7, 1), xArray6(8, 1), xArray6(9, 1), xArray6(10, 1)
                    xNumbers.Cells(i, j + 1).Interior.ColorIndex = 7
                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
Cloud Class® Course: SQL Server Core 2016

This course will introduce you to SQL Server Core 2016, as well as teach you about SSMS, data tools, installation, server configuration, using Management Studio, and writing and executing queries.

 
redmondbCommented:
Pedro,

BTW, a significant part of the above macro is handling the table on the Update sheet. If you instead just considered ranges of numbers (0 to 9, 10 to 19, etc.) then this would dramatically simplify the code (and speed up the run further).

Regards,
Brian.
0
 
Pedrov664Author Commented:
Brian,

Ran the code and it runs superb as to speed.

P.S. rearrainging the numbers makes no difference to me, however, the data does not contain any zero as a value.

P.P.S.

1) I noticed that it automatically selects and colors all cells in record time by the way. However, it should allow me to choose which cells to color, this way it runs only on the cells chosen.

2) I noticed that it colord cells in the G block. which I do not intend to color. If you allow me choose which cells to color before coloring them it would be great and would tackle this issue.

P.P.S. 1697 rows processed in 1 second is excellent because I can't find a better word for it. Stupendious, magnificent, anyway I think you understand it now. You did a great job on speeding things up.
0
 
redmondbCommented:
Pedro,

Because selections may have multiple areas and may not take all data columns, this is not a trivial change. It'll probably be tomorrow before I can provide an updated version.

Cheers,
Brian.
0
 
Pedrov664Author Commented:
Brian,

no problem at all.

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_Numbers_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 Range
Dim xSelection1 As Range
Dim xSelection2 As Range
Dim xSelection3 As Range
Dim xSelection4 As Range
Dim xSelection5 As Range
Dim xSelection6 As Range
Dim xNumbers    As Worksheet

StartTime = Timer

Set xNumbers = Sheets("Numbers")

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 0 To 9
                        ' Nothing to do as this is the default.
                    Case 10 To 19
                        xNumbers.Cells(i, j).Interior.ColorIndex = 4
                    Case 20 To 29
                        xNumbers.Cells(i, j).Interior.ColorIndex = 14
                    Case 30 To 39
                        xNumbers.Cells(i, j).Interior.ColorIndex = 12
                    Case 40 To 49
                        xNumbers.Cells(i, j).Interior.ColorIndex = 13
                    Case 50 To 59
                        xNumbers.Cells(i, j).Interior.ColorIndex = 7
                    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 "Processed " & xCells & " cells in " & Format(Timer - StartTime, "000") & " seconds."
MsgBox ("Processed " & xCells & " cells in " & Format(Timer - StartTime, "000") & " seconds.")

End Sub

Open in new window

Regards,
Brian.
0
 
Pedrov664Author Commented:
You have exceeded expectations!
0
 
redmondbCommented:
Thanks, Pedro!
0
 
Pedrov664Author Commented:
No problem, you deserve it!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 5
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now