Dec 28 2018 10:39 AM
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.
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.
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 :)
Dec 28 2018 12:11 PM - edited Dec 28 2018 12:17 PM
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
Dec 28 2018 02:24 PM
Thanks for trying to help.
But nothing works for me.
Maybe i can send You a copy of my worksheet?
Dec 28 2018 02:38 PM
For me is working only that Macro which i need to run manually.
Dec 28 2018 02:45 PM
SolutionSorry, 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
Dec 28 2018 02:56 PM
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.
Dec 28 2018 03:07 PM
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.
Dec 28 2018 03:12 PM
Thanks :)
You've helped me a lot :)
Happy Holidays :)
Dec 28 2018 03:16 PM
Dec 31 2018 06:23 AM
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
Mar 07 2019 03:25 PM
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 :)
Dec 28 2018 02:45 PM
SolutionSorry, 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