Highlighting Repeating Number Pairs

[binar]

Fellow Forum Members,
I have come to the realization Excel's Conditional Formatting feature can't handle what I'm trying to do which is to highlight repeating number pairs using a pallette of 10 color highlights for data residing within a 4 column matrix and X amount of rows.

The example data below shows repeating number pairs in BOLD. So for "8 & 9" Yellow is applied, for "25 & 39" Blue is applied and for "10 & 13" Green is applied as a highlight until a color pallette of 10 colors is used up. If 15 pairs are found the color pallette just start over again. Is this possible to make happen using a VBA script? Any assistance will be greatly appreciated. Thanks in advance.



8
9
25
39


4
10
36
38


8
9
33
42


8
19
25
39


10
13
39
42


4
25
34
39


5
23
32
35


16
21
26
27


4
10
11
13

[binar]

Forgot to mention I'm dealing with data that only contains number values within the range of 1 through 99. Just in case this information is required for inclusion into the VBA script.

[SamT]

Are the numbers always in ascending order in any given row?

Is there a reason to limit the colors to ten?

[binar]

Are the numbers always in ascending order in any given row?

Is there a reason to limit the colors to ten?


SamT,
Thanks for your reply. To answer your questions. No it does not matter what the color limit is. I picked TEN as a limit because I figured it might make it easier to VBA code. But if it's easier to use a lot more colors than TEN than by all means use as many colors as you want. What I would like to see is the same color applied to all of the matching number pairs. So for example, if the number pair 10 & 13 appear eight times all occurences of 10 & 13 should all have the same color applied, for example BLUE. And if the number pair 8 & 9 appear eleven times all occurences of 8 & 9 should all have the same color applied, for example GREEN.


As for your question regarding if all numbers are in ascending order. The answer is yes. Each row has numbers ascending from the left column over to the right column. In the left column is the smallest number and and the farthest right column is the biggest number. If you have any more questions please post them. And thanks again for you post.

[binar]

Any help will be greatly appreciated. Thanks

[Aussiebear]

Should 4 & 10 also be considered as a repeating pair? (2nd row and last row)

[binar]

Aussiebear,
You are correct. I don't know how I overlooked the numbers 4 & 10. This just goes to show how helpful a VBA script that finds and highlights matching pairs would be. It's easy to overlook number pairs when doing it manually. Any help will be greatly appreciated. Thanks.


Should 4 & 10 also be considered as a repeating pair? (2nd row and last row)

[Kenneth Hobs]

To make a logical program, we need to understand your logic or rules in other words.

1. Are all pairs the same color?
a. Both pairs of 10 and 13 are blue, or
b. Each 10 13 pair is another color.
2. If 10 13 is blue, and 4 10 is red, then what color would be 10 in the last row? In this case, there is an overlap where 10 occurs in 4 10 and 10 13 and could even be 10 11 overlap if the dataset is big enough.

Attaching a short example file helps us help you.

[SamT]

As I understand the rules
All numbers are ascending left to right
Each Set of Pairs should be a different color until run out of colors, then repeat.

The only way I can think to handle the 4- 10 - 13 in the last row is IF in any new Set of pairs any colorIndex is not xlColorIndexNone then that triple set gets a reserved color, maybe Red. It wouldn't take much code to skip a reserved color, but does add a check on each found pair and another loop.


CI = 2
Do 'Loop
If CI = 56 then CI = 2
code here
IF new pair set found then CI = CI + 1
End code
If CI = Red Then CI = CI + 1
Loop


Alternately, ignore the problem and realize that a single cell in any color must have a cell of another color as its companion. Either way, there's going to be a visual search.

On second thought If only the shared Cell is Red, then the visual search is for a limited set of pairs.


I wonder how many columns this range uses?

[binar]

Ken,
It's great to see you still visit this forum. You play a big role in making this VBA forum the best one around. Attached is an example Excel file. It addresses the logic better than I did in my first post in this thread. What I'm proposing inside the Excel file is to reserve the color RED for rows with matching number pairs where an overlap exists. So as you can see below for the "4 & 10" and "10 & 13" matching number pairs the rows are shown in RED. I hope this logic is solid.



8
9
25
39


4
10
36
38


8
9
33
42


8
19
25
39


10
13
39
42


4
25
34
39


5
23
32
35


16
21
26
27


4
10
11
13

[binar]

SamT,
Thanks for your post. I just found out you posted in this thread while I was busy preparing my reply post to Ken. I find it to be a funny coincidence you and I picked the same color RED as a reserve color. Moreover, I agree with you that using RED as a reserve color where an overlap exists is probably the best approach to take. As for the quantity of columns, right now I am only restricting it to four columns. As for the other logic related concerns you mention I hope my attached example file in Ken's post clarifies things for you. Nevertheles, thank you very much for your contribution to this thread and making this VBA forum the best around.

[Aussiebear]

36 & 38, 39 & 42 are not matching pairs despite being colored in your example

[SamT]

Here's my attempt. It works through the range just fine, but I have a logic error somewhere. It tends to color all but the first cell in any row with the same color, but it does it as it progresses down the rows.

I know it's something simple and stupid, but I'm tired of playing with it, and there are greater coders than me interested in this thread.

Maybe it will give someone some ideas.

BTW, don;'t use Red until the rest is working.


Option Explicit

Sub FindAndColorPairs()

'Selection Ranges
Dim CompareRange As Range
Dim CheckingRow As Long 'The Row we are selecting numbers to find pairs of
Dim CheckingColumn As Long 'Current column of possible first number of pair
Dim CompareColumn As Long 'Current column of possible second number of pair
Dim CompareRow As Long

'Found Ranges
Dim FirstNum As Range 'Set if First numbe in possible pair is found
Dim SecondNum As Range 'Similar to FirstNum
Dim PairFound As Boolean

'Colors
Const CIRed As Long = 3
Dim CIArray
Dim CIAI As Long 'ColorIndexArrayIndex

CIArray = Array(4, 6, 7, 8, 9, 10, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, _
23, 24, 26, 27, 31, 33, 34, 36, 37, 38, 39, 40, 41, 42, 43, 44, _
45, 46, 47, 48, 50, 53, 54)
CIAI = 0
'If CIAI = 55 Then CIAI = 0

Set CompareRange = Selection
With CompareRange
.Interior.ColorIndex = xlColorIndexNone
For CheckingRow = 1 To .Rows.Count - 1
For CheckingColumn = 1 To .Columns.Count - 1
For CompareColumn = 2 To .Columns.Count
For CompareRow = 2 To .Rows.Count
With .Rows(CompareRow)
Set FirstNum = .Find(CompareRange.Cells(CheckingRow, CheckingColumn))
If Not FirstNum Is Nothing Then
Set SecondNum = .Find(CompareRange.Cells(CheckingRow, CompareColumn))

If Not SecondNum Is Nothing Then
PairFound = True
' Checking for already matched Pair
If Not FirstNum.Interior.ColorIndex = xlColorIndexNone Then _
If FirstNum.Interior.ColorIndex = SecondNum.Interior.ColorIndex Then _
GoTo CompareRowNext
If FirstNum.Interior.ColorIndex = xlColorIndexNone Then _
FirstNum.Interior.ColorIndex = CIArray(CIAI)
'Else: FirstNum.Interior.ColorIndex = CIRed
'End If
If SecondNum.Interior.ColorIndex = xlColorIndexNone Then _
SecondNum.Interior.ColorIndex = CIArray(CIAI)
'Else: SecondNum.Interior.ColorIndex = CIRed
'End If
End If 'SecondNum
End If 'FirstNum
End With
CompareRowNext:
Next CompareRow

If PairFound Then
.Cells(CheckingRow, CheckingColumn).Interior.ColorIndex = CIArray(CIAI)
.Cells(CheckingRow, CompareColumn).Interior.ColorIndex = CIArray(CIAI)
End If
Next CompareColumn

If PairFound Then
CIAI = CIAI + 1
If CIAI = UBound(CIArray) + 1 Then CIAI = 0
PairFound = False
End If
Next CheckingColumn
Next CheckingRow
End With
End Sub

[binar]

SamT,
Thank you very much for posting your code in this thread. I tested your code and it's real cool how all the colors appear like magic inside the cells. As you said it still needs work. Hopefully, Kenneth Hobs might get a chance to take a look at it. Currently, the matching number pairs "2 & 12" don't share a common color as shown below. In short, there should be a lot less colors showing and more white cells since there are not a lot of matching number pairs. Nevertheless, your code proves that applying hightlights to cells is possible. I hope someone out there can refine your code so that the color hightlights are only be applied to matching number pairs.




2
12
16
18
15


5
9
21
31
18


2
12
16
18
15


18
26
31
40
17


2
6
10
32
5


3
16
21
41
7


3
4
10
19
21


1
3
10
44
10


5
27
30
38
12





Regarding what Aussiebear mentioned about 36 & 38, 39 & 42 are not matching numbers. You are correct Aussiebear, they don't match however they are on the same row where the number 10 overlaps with a couple of pairs. So in this case, I am thinking the most logical approach is to just highlight in RED the entire row where the overlap occurs. The alternative option would be not to hightlight the entire row and instead just highlight the number 10 with a reserve color that shows it's shared by several matching number pairs. If anyone out there has a better logical way to address overlapping numbers please by all means post your suggestion. I am interested in approaching this in the most logical way. Any opinion welcomed. Thanks.

[SamT]

I have changed
For CompareRow = 2 To .Rows.Count[/CODE] to

For CompareRow = CheckingRow + 1 To .Rows.Count Which helped and added a Set FoundPair = False to where I thought it should be :rofl:

But it is still looping up into already checked rows and recoloring them.:banghead:

[SamT]

BTW, The code I use to find out which ColorIndexes to use is to first select any group of 56 or more cells (8x7) then run


With Selection
For i = 1 to 56
.Cells(i).Value = i
.Cells(i).Interior.ColorIndex = i
Next i
End With

Then I picked out the cells whose value I could read in standard font color, and only one color of any that were too close in hue to easily see the difference.

[nilem]

Hi binar (http://www.vbaexpress.com/forum/member.php?38727-binar),
Perhaps it would be a suitable option for you
Try

Sub ertert()
Dim x, y(), i&, j&, n&, u&, s$, k, sp, ssp
Application.ScreenUpdating = False
x = Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x), 1 To 6)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
u = 0
For j = 1 To UBound(x, 2)
For n = j + 1 To UBound(x, 2)
s = x(i, j) & "~" & x(i, n)
u = u + 1: y(i, u) = s
If .Exists(s) Then
.Item(s) = .Item(s) & "|" & i & ";" & u
Else
.Item(s) = i & ";" & u
End If
Next n
Next j
Next i: n = 0
For Each k In .keys
If InStr(.Item(k), "|") Then
n = n + 1: sp = Split(.Item(k), "|")
For j = 0 To UBound(sp)
ssp = Split(sp(j), ";")
Cells(ssp(0), ssp(1) + 7).Interior.Color = n * 100000
Next j
End If
Next k
End With
Range("H1").Resize(i - 1, u).Value = y
Application.ScreenUpdating = True
MsgBox n & " pairs are repeats", 64
End Sub

[snb]

Your extended list contains so many doubles that colouring the repeated doubles confuses more than it clarifies.
So my suggestion is to colour only the first encountered repeated unique pairs.

Sub M_snb()
sn = Cells(1).CurrentRegion
sc = Cells(1).CurrentRegion.Offset(, Cells(1).CurrentRegion.Columns.Count)

For j = 1 To UBound(sn)
c00 = c00 & vbCr & "|" & Join(Application.Index(sn, j, 0), "|") & "|_" & j
Next
sp = Split(c00, vbCr)

y = 2
For j = 1 To Application.Max(sn) - 1
sq = Filter(sp, "|" & j & "|")
st = Filter(Split(Join(sq, "|"), "|"), "_", False)
For jj = 1 To UBound(st)
If Val(st(jj)) > j Then
sr = Filter(sq, "|" & st(jj) & "|")
If UBound(sr) > 0 Then
For jjj = 0 To UBound(sr)
x = Split(sr(jjj), "_")(1)
x1 = Application.Match(Format(j), Split(sr(jjj), "|"), 0) - 1
x2 = Application.Match(Format(st(jj)), Split(sr(jjj), "|"), 0) - 1
If sc(x, x1) = "" And sc(x, x2) = "" Then
sc(x, x1) = y
sc(x, x2) = y
End If
Next
y = y + 1
End If
End If
Next
Next

For j = 1 To UBound(sc)
For jj = 1 To UBound(sc, 2)
If sc(j, jj) <> "" Then Cells(j, jj).Interior.ColorIndex = sc(j, jj) Mod 56
Next
Next
End Sub

[snb]

To illustrate what I mean see the attachment.

[binar]

snb,
Thanks a million for your postings. I saw your attachment that illustrates your point and I do agree. You can't see the tree from the forest with all those colors. I wasn't anticipating that too much colors could actually not be helpful. Your first VBA that only colors the first encountered repeated pair is more cleaner to read. Nevertheless, thanks again for your contribution to this thread. And thanks to everyone who contributed to this thread. This forum is awesome

[binar]

nilem,
Thanks a million for your posting in this thread. I tested your VBA and I was pleasantly surprised to see you are using a unique method to data output. I like how your VBA arranges the data in a way I didn't think was possible. It's very clean to read and minimizes confusion compared to the approach I was describing. Thank you very much for sharing your VBA coding skills. I have learned some new VBA coding concepts with the approach you took. Again thank you very much and this thread can be considered SOLVED.