SOLVED

Excel highlight numbers in range by input

Copper Contributor

I pretty much forgot about VBA, cause i was learning it in school.
But i like to do something in Excel.
Let's take a look at my tables from beginning.

 

1a.PNG


This all is just for my lottery Statistics.

In table A i'm writing in numbers, which i have chosen in lottery tickets. (5 X 20 numbers )
In table B i'm writing those number which was drawn in TV lottery. (20+ NUMBERS)

So I want to make a VBA code to highlight cells in table A when the same number is written / inputted in table B. But i don't highlight any blank values, cause not always I'm playing all 5 variants in game, and not all N's are numbers in table B
For example, i input number 47 in table B, and it highlights all cells with number 47 in table A with green fill colour.
I've already made CountCColor in VBA, but i need to make VBA for automatically highlighting numbers inputted by me in B to A.
Conditional formatting is not good for this :D

For example Tables 2.

1ab.PNG

 

I bought 1 lottery ticket from possible 5. Have chosen my 20 numbers TableA. And numbers in TableB were drawn in lottery. I used Kutools trial there but, is it possible somehow to do that with built in Excel options or VBA?
I just need highlight numbers (green) in B4:F23 which will be or was inputted in H4:L23.

Thanks in advance :)
Happy holidays :)

 



11 Replies

Hi, Here are a couple of options, If you want to have the coloring happen only when you manually run the code stick this in a module:

 

Sub Color()

Dim TicketRange As Range
Dim DrawRange As Range
Dim Cell As Range
Dim CheckRange As Range

Set TicketRange = Range("B4:F23")
Set DrawRange = Range("H4:L23")

For Each Cell In TicketRange

Set CheckRange = Range("H4:L23").Find(What:=Cell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not CheckRange Is Nothing And Cell.Value <> "" Then

Cell.Interior.ColorIndex = 4

End If

Next Cell

End Sub

Sub UnColor()

Dim TicketRange As Range
Dim Cell As Range

Set TicketRange = Range("B4:F23")

For Each Cell In TicketRange

Cell.Interior.ColorIndex = 0

Next Cell

End Sub

 If you want the code to run every time you change a cells value on the worksheet than stick this in the VBA for your worksheet:

 

Private Sub Worksheet_Change(ByVal Target As Range)

Dim TicketRange As Range
Dim DrawRange As Range
Dim Cell As Range
Dim CheckRange As Range

Set TicketRange = Range("B4:F23")
Set DrawRange = Range("H4:L23")

For Each Cell In TicketRange

Set CheckRange = Range("H4:L23").Find(What:=Cell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not CheckRange Is Nothing And Cell.Value <> "" Then

Cell.Interior.ColorIndex = 4

Else

Cell.Interior.ColorIndex = 0

End If

Next Cell

End Sub

Thanks for trying to help.
But nothing works for me.

Maybe i can send You a copy of my worksheet?

For me is working only that Macro which i need to run manually.

best response confirmed by NaurisLatvia28 (Copper Contributor)
Solution

Sorry, I didn't realize you had this on multiple worksheets in the workbook, changed to a workbook change event. So the code goes in ThisWorkbook. Added to what you had posted and attached. 

 

 

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim TicketRange As Range
Dim DrawRange As Range
Dim Cell As Range
Dim CheckRange As Range

Set TicketRange = Range("B4:F23")
Set DrawRange = Range("H4:L23")

For Each Cell In TicketRange

Set CheckRange = Range("H4:L23").Find(What:=Cell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not CheckRange Is Nothing And Cell.Value <> "" Then

Cell.Interior.ColorIndex = 4

Else

Cell.Interior.ColorIndex = 0

End If

Next Cell

End Sub

 

Oh thanks :)
It's working :)

I'll learn from it, I promise :)
But is it possible to make that the count of coloured numbers shows automatically when it's matching number in lottery range from draw range?
Because when i use Your VBA code, it's working good. But when i enter in draw range, i need to P7 - P11 manually and hit enter.

You can force recalculation of the workbook (Ie. your function which is not auto recalculating) by adding this line to the end of my sub:

 

Application.Calculate

 

I can maybe come up with something a bit more elegant but I've got to take off now. 

Thanks :)
You've helped me a lot :) 
Happy Holidays :)

Your welcome. Happy Holidays to you as well.

You should change your count function to not key off colour though, I won’t say I’ve never done it but it’s not really good practice. Should check for matches the same way the colouring macro does. If I get some time I will try to write an alternative for you.

Thanks again :)

Good Morning, Here is my proposal for a rewrite for your count color function not relying on cell color. As I mentioned before using cell color is not a preferred way of doing this (Tend to run into issues, such as the one we had before where you had to manually recalculate these functions, Excel does not recognize a change in a cell color as a needed trigger to recalculate functions.) If you there is a logic as to why cells on a worksheet are colored always try to go back to using that logic to create your function/sub. Arguments are now the range of cells for that ticket and the range of cells for the called numbers. 

 

 

Option Explicit

Function CountCcolor(TicketRange As Range, DrawRange As Range) As Long

Dim Cell As Range
Dim CheckRange As Range

For Each Cell In TicketRange

Set CheckRange = DrawRange.Find(What:=Cell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not CheckRange Is Nothing And Cell.Value <> "" Then

CountCcolor = CountCcolor + 1

End If

Next Cell

End Function

 I redid the macros as well, what I had sent you before had the macro called every time any cell value was changed, added a few lines to check that the cell value that was changed is within the range of the ticket numbers or the draw numbers before calling the macro. Probably not all that critical on your workbook but this will speed things up if you are doing anything else on worksheets in this workbook. Sample attached. Thank you. 

 

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim TicketRange As Range
Dim DrawRange As Range

Set TicketRange = Sh.Range("B4:F23")
Set DrawRange = Sh.Range("H4:L23")

If InRange(Target, TicketRange) Or InRange(Target, DrawRange) Then

Call ColorCells(Sh)

End If

End Sub

Function InRange(Range1 As Range, Range2 As Range) As Boolean

InRange = Not (Application.Intersect(Range1, Range2) Is Nothing)

End Function

Private Sub ColorCells(ByVal Sh As Object)

Dim TicketRange As Range
Dim DrawRange As Range
Dim Cell As Range
Dim CheckRange As Range

Set TicketRange = Sh.Range("B4:F23")
Set DrawRange = Sh.Range("H4:L23")

For Each Cell In TicketRange

Set CheckRange = DrawRange.Find(What:=Cell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not CheckRange Is Nothing And Cell.Value <> "" Then

Cell.Interior.ColorIndex = 4

Else

Cell.Interior.ColorIndex = 0

End If

Next Cell

End Sub

 

 

Hi :) 
Sorry for my very late response!

I was working on some projects and new things, so i didn't managed to watch Your last attached file :(

But i opened it couplde days ago :)
And You know what? 

Your code learned me a lot and i used (what i learned from Your code) in other my projects and works, 

I learned and used the principe of your code.
In completely different topics.

What I learned from your code helped me a lot and made me understand many things that I did not understand before.

Thanks :) 

1 best response

Accepted Solutions
best response confirmed by NaurisLatvia28 (Copper Contributor)
Solution

Sorry, I didn't realize you had this on multiple worksheets in the workbook, changed to a workbook change event. So the code goes in ThisWorkbook. Added to what you had posted and attached. 

 

 

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim TicketRange As Range
Dim DrawRange As Range
Dim Cell As Range
Dim CheckRange As Range

Set TicketRange = Range("B4:F23")
Set DrawRange = Range("H4:L23")

For Each Cell In TicketRange

Set CheckRange = Range("H4:L23").Find(What:=Cell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not CheckRange Is Nothing And Cell.Value <> "" Then

Cell.Interior.ColorIndex = 4

Else

Cell.Interior.ColorIndex = 0

End If

Next Cell

End Sub

 

View solution in original post