Help with matching in VBA

[JonnyB]

Hi Guys

Can anyone help with the following

Need to match contents of 2 cells that are next to each other with the same contents in another 2 cells that are next to each other and then colour each range grey (as long as match exactly) e.g.

C56 = 494, D56 = 27

E84 = 494, F84 = 27

Range C56 to F56 grey
Range C84 to F84 grey

If F84 was 26 then obviously no match

any ideas

Appreciate any help

thanks
Jon

[JonnyB]

Is this even possible?

[Yongle]

Yes it is possible.
Is it just the cells you specified or could it be any group of 4 cells matching that same pattern?

[Yongle]

Here are some vba examples (but you could achieve both of these with conditional formatting in Excel)
Note the use of the useful "Union" function to apply formatting to disparate cells at same time

1) colour the cells grey if the values of the 2 pairs of cells are equal to each other regardless of value


'match specific cells
With ActiveSheet
If .Range("C56") = .Range("E84") And .Range("D56") = .Range("F84") Then
Set MyRange = Union(.Range("C56"), .Range("D56"), .Range("E84"), .Range("F84")) 'selects all the cells to be formatted
MyRange.Interior.ColorIndex = 16 'changes cell colours to grey
Else
'do nothing
End If
End With


2) colour the cells grey if the the values of the 2 pairs of cells are equal to the specific values specified


'match specific cells and specify their values
With ActiveSheet
If .Range("C56") = 494 And .Range("E84") = 494 Then
If .Range("D56") = 27 And .Range("F84") = 27 Then
Set MyRange = Union(.Range("C56"), .Range("D56"), .Range("E84"), .Range("F84"))
MyRange.Interior.ColorIndex = 16
End If
End If
End With


Further questions:
The vba has effected permanent changes on those cells. Would you want the cells to revert to default if the values changed ?

Do you want vba to trawl through the 4 columns looking for any matching "pairs of values"?
If so, we need more information, but still possible (such as do the pairs just need to match, is it only pairs, could there be lots of matches etc).

[JonnyB]

Hi Yongle,

Thanks for the reply - the 2 pairs could be on any row from say row 3 to row 5000. One pair would be in cols C & D and the other pair in E & F. The values will
be different so any matching pairs in that range.


thanks for your help
Jon

[Yongle]

Try this
Thought process
To avoid a plethora of if statements - if cell(C)= cell(E), if cell(D)=cell(F) etc - I try to build a single-field tests.
- here I have created two strings (one for each adjacent pair of cells)
- so that I can test if string of cell(C) & cell(D) = string of cell(E) & cell(F)
- have included a "hyphen" in between the 2 cell values which
(a) turns numbers into text
(b) avoids false positives (12) & (345) =12345, as does (123) & (45) = 12345 but 12-345 <> 123-45
which means that it satisfies cell(C) =cell(E) and cell(D) = cell(F)

What macro it does
- creates 2 arrays to hold built single-field values
- with "row number" of underlying data = "position" of related values "in each array"
- compare array values for a match
- capture matching cell references using Union function
- colour in "grey" the final range defined by Union function

For you to consider
- this compares approx 5000 values with approx 5000 = 25,000,000 checks
- this will find every occurrence of Cell(C)Cell(D) matching Cell(E)cell(F)
- if there will only ever be one match then could speed up the coding and just look for first match
- perhaps you only want "first" match to be grey

Run macro from the sheet where the values are.



Sub EveryMatch()
'macro matches pairs of values in adjacent cells in 2 pairs of columns
Dim CDarray(5001) As String, EFarray(5001) As String
Dim MatchedUnion As Range, DimDummyRange As Range
With ActiveSheet
'build the 2 arrays
For i = 3 To 5000
CDarray(i) = .Cells(i, 3) & "_" & .Cells(i, 4)
EFarray(i) = .Cells(i, 5) & "_" & .Cells(i, 6)
Next i
'set MatchedUnion and DummyRange
Set DummyRange = Union(.Range("C1"), .Range("D1"), .Range("E1"), .Range("F1"))
Set MatchedUnion = DummyRange
'compare the values in each array
For i = 3 To 5000
For J = 3 To 5000
If CDarray(i) = EFarray(J) Then
'create a union of all the matching cells (the "future" grey cells)
Set MatchedUnion = Application.Union(MatchedUnion, .Range("C" & i), .Range("D" & i), .Range("E" & J), .Range("F" & J))
End If
Next J
Next i
'apply colour to matched cells
.Range("C3:F5000").Interior.ColorIndex = xlNone 'reset full range
MatchedUnion.Interior.ColorIndex = 15 'make matching cells grey
DummyRange.Interior.ColorIndex = xlNone 'reset dummy range
End With
End Sub

[JonnyB]

Thanks Yongle

Code really slow so changed the range to 200 to speed it up (I can adjust this as necessary). I placed matching pairs in C3D3 & E10F10 but the code shaded the whole range i.e. C3 to F200. I'd want it to shade ranges C3 to F3 & C10 to F10 only for that matching pair. All other unmatched pairs to remain white until matched

thanks again
Jon

[Yongle]

Yes - when doing 25,000,000 matches it will take a while! To speed it up we must reduce the number of checks it makes. So what are we checking for AFTER we find a match?

At the moment the code finds a match for (C10)(D10) and will continue checking all the other possible values in columns E & F

To speed up we could say:
"match found" Cell(C10)Cell(D10)combo MATCHES Cell(E15)cell(F15)combo
move to (C11)(D11) Find a match that does not include (E15)(F15) etc
Is that what you want?

[JonnyB]

Sorry - I must be more specific - once it finds the match it should stop searching - there will only ever be one pair that matches with another pair.

So if C3 = 474 , D3 = 27 & E10 = 474 , F10 = 27 - matched pairs found, stop searching, shade ranges C3 to F3 & C10 to F10

really grateful for your continued help

Jon

[Yongle]

So you are saying
FIND first match
STOP searching
Yes??

[JonnyB]

Apolgies again - yes please find first match then stop searching

thanks

[Yongle]

Here you go then.

This will look for the first match (without specifying any values).
Have added message box (at end of code) telling you where the matched values can be found.

If you want the values narrowing down specifically to
C3 = 474 , D3 = 27 & E10 = 474 , F10 = 27
then I will amend it again for you




Sub FirstMatch()
'macro matches pairs of values in adjacent cells in 2 pairs of columns
Dim CDarray(5001) As String, EFarray(5001) As String, MatchedCells As String
Dim MatchedUnion As Range, DimDummyRange As Range
With ActiveSheet
'build the 2 arrays
For i = 3 To 5000
CDarray(i) = .Cells(i, 3) & "_" & .Cells(i, 4)
EFarray(i) = .Cells(i, 5) & "_" & .Cells(i, 6)
Next i
'set MatchedUnion and DummyRange
Set DummyRange = Union(.Range("C1"), .Range("D1"), .Range("E1"), .Range("F1"))
Set MatchedUnion = DummyRange
'compare the values in each array
For i = 3 To 5000
For j = 3 To 5000
If CDarray(i) = EFarray(j) Then
'create a union of all the matching cells (the "future" grey cells)
Set MatchedUnion = Application.Union(MatchedUnion, .Range("C" & i), .Range("D" & i), .Range("E" & j), .Range("F" & j))
MatchedCells = "Matched Cells = " & vbNewLine & .Range("C" & i & ":D" & i).Address(0, 0) & vbNewLine & .Range("E" & j & ":F" & j).Address(0, 0) & vbNewLine & "With values = " & vbNewLine & .Range("C" & i).Value & vbNewLine & "and" & vbNewLine & .Range("D" & i).Value
j = 5000
i = 5000
End If
Next j
Next i
'apply colour to matched cells
.Range("C3:F5000").Interior.ColorIndex = xlNone 'reset full range
MatchedUnion.Interior.ColorIndex = 15 'make matching cells grey
DummyRange.Interior.ColorIndex = xlNone 'reset dummy range
MsgBox MatchedCells
End With
End Sub

[JonnyB]

Thanks Yongle,

This does work finding the first matched pair and shade range grey to signal a match.

I may have misled you again (so sorry) - I would need to run the macro again so that if anyone updates the sheet in column E & F later then it would find further matching pairs.

E.g. 474,27 C3D3
......454,25 C4D4
......464,26 C5D5

Someone inputs 474,27 in E10F10 - macro would auto match the first pair & shade the 2 ranges

Then someone later inputs 454,25 in to E20,F20 - again there would be a match and shade the 2 ranges after running the macro again

and again later someone inputs 464,26 in to E40,F40 - again match & shade the 2 ranges when running the macro

apologies if I am confusing matters
regards
jon

[Yongle]

So are you saying that after the first matching

if someone inputs again
Leave the grey cells grey
Find the next match and colour those cells grey
(now we have 8 grey cells)

if Someone inputs again
Leave the grey cells grey
Find the next match and colour those cells grey
(now we have 12 grey cells)

etc

[JonnyB]

yes - sorry i didn't make this clear

thanks
jon

[Yongle]

No problem
I need to re-think approach.
To keep re-running this code is possible, but would be too slow.
I will try a few different ideas before getting back to you.

[Yongle]

Just one more question
You seem to know that there will only be one match
So will you know the actual matching values?

[Yongle]

Try this - run from the sheet containing the values

What this does
- creates a single field as before but this time dumps values into columnA in a temporary worksheet
- checks for any previously "greyed" cells and deletes them from columnA
- uses CountIf function against remaining values in columnA
- those with a count of 2 must be the new matched pair
- applies "grey" to appropriate cells
- deletes temp worksheet



Sub TurnMatchedPairsGrey()
Dim ws As Worksheet, ws1 As Worksheet
Set ws1 = ActiveSheet


'add temporary worksheet
Set ws = Worksheets.Add(Before:=Worksheets(1))


'create cells with values to compare
For i = 3 To 5000
ws.Cells(i, 1) = ws1.Cells(i, 3) & "_" & ws1.Cells(i, 4)
ws.Cells(i + 5000, 1) = ws1.Cells(i, 5) & "_" & ws1.Cells(i, 6)
Next i
'Look for previous grey cells
For i = 3 To 10000
If ws1.Cells(i, 3).Interior.ColorIndex = 15 Then
ws.Cells(i, 1).ClearContents
End If
If ws1.Cells(i + 5000, 5).Interior.ColorIndex = 15 Then
ws.Cells(i, 1).ClearContents
End If
Next i
'use CountIf function to look for count = 2
For i = 3 To 5000
If Application.WorksheetFunction.CountIf(ws.Range("A3:A10000"), ws.Range("A" & i)) = 2 Then
ws1.Cells(i, 3).Interior.ColorIndex = 15
ws1.Cells(i, 4).Interior.ColorIndex = 15
End If
Next i
For i = 5001 To 10000
If Application.WorksheetFunction.CountIf(ws.Range("A3:A10000"), ws.Range("A" & i)) = 2 Then
ws1.Cells(i - 5000, 5).Interior.ColorIndex = 15
ws1.Cells(i - 5000, 6).Interior.ColorIndex = 15
End If
Next i

Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = False
End Sub

[JonnyB]

Hi Yongle,

Yes these 'pairs' will be matched at some point in the future.

Code works great

thanks very much for your help

regards
Jon

[Yongle]

Hi Jon
Glad we got there.
Please go to top of thread and under "Thread Tools" mark the thread as "Solved"
thanks
Yon