|
Calculating matches between two sets
Flexalong, I first came up with the macro Match_4Plus which does what you want but I found I could improve it to provide more useful results; it is the macro named Show_4Plus.
A – Set-up of the sheet:
On the first row in cells A1:O1, place titles as you like but in cell H1, enter the formula =COUNT(B:B) and the formula =COUNT(J:J) in cell P1. This will indicate how many rows of data are in each group of data.
Then starting on the second row and going down as necessary, place the first group of numbers in columns B to G and the second group of numbers in columns J to O. I used columns A and I to put a sequential number for each set of numbers (in your example, 1 to 11 for the first group and 1 to 37 for the second group). This is optional for the first macro but necessary in the second one.
B – Code for common declarations:
In the macro module, place the following lines at the top to declare variables as Integer (this should be more than enough for both procedures):
Option Explicit
Dim Data_1() As Integer, Data_2() As Integer
Dim N1 As Integer, N2 As Integer, Nx4 As Integer, nRow As Integer
Dim I As Integer, J As Integer, K As Integer, L As Integer
C – Code for the Match_4Plus procedure
This is the listing for the first macro:
Sub Match_4Plus()
Range("A1").Select
Application.ScreenUpdating = False
N1 = Range("H1").Value
N2 = Range("P1").Value
ReDim Data_1(N1, 6), Data_2(N2, 6)
For I = 1 To N1
For J = 1 To 6
Data_1(I, J) = ActiveCell.Offset(I, J).Value
Next J
ActiveCell.Offset(I, 7).Value = ""
Next I
For I = 1 To N2
For J = 1 To 6
Data_2(I, J) = ActiveCell.Offset(I, J + 8).Value
Next J
Next I
For I = 1 To N1
For J = 1 To N2
Nx4 = 0
For K = 1 To 6
For L = 1 To 6
If Data_1(I, K) = Data_2(J, L) Then Nx4 = Nx4 + 1
Next L
Next K
If Nx4 >= 4 Then ActiveCell.Offset(I, 7).Value = True
Next J
Next I
Application.ScreenUpdating = True
End Sub
D – Output of the preceding macro
In column H, you will get a TRUE value for the where 4 or more values in columns B to G match values on a line in columns J to O. If less than 4 numbers match, it will be left blank. In your example, only the cell H11 (for set #11) will show a TRUE value.
E - Code for the improved Show_4Plus procedure
This is the listing for the second macro:
Sub Show_4Plus()
Range("A1").Select
Application.ScreenUpdating = False
N1 = Range("H1").Value
N2 = Range("P1").Value
ReDim Data_1(N1, 6), Data_2(N2, 6)
nRow = 1
Do While ActiveCell.Offset(nRow, 17).Value <> ""
ActiveCell.Offset(nRow, 17).Value = ""
ActiveCell.Offset(nRow, 18).Value = ""
ActiveCell.Offset(nRow, 19).Value = ""
nRow = nRow + 1
Loop
For I = 1 To N1
For J = 1 To 6
Data_1(I, J) = ActiveCell.Offset(I, J).Value
Next J
Next I
For I = 1 To N2
For J = 1 To 6
Data_2(I, J) = ActiveCell.Offset(I, J + 8).Value
Next J
Next I
nRow = 0
For I = 1 To N1
For J = 1 To N2
Nx4 = 0
For K = 1 To 6
For L = 1 To 6
If Data_1(I, K) = Data_2(J, L) Then Nx4 = Nx4 + 1
Next L
Next K
If Nx4 >= 4 Then
nRow = nRow + 1
ActiveCell.Offset(nRow, 17).Value = I
ActiveCell.Offset(nRow, 18).Value = J
ActiveCell.Offset(nRow, 19).Value = Nx4
End If
Next J
Next I
Application.ScreenUpdating = True
End Sub
F – Output of the preceding macro
In columns R to T, stating in row 2, when you have 4 or more matches, you will get the set number from the first group (taken from column A), then the set number from the second group (taken from column I) and finally, the number of matches between the two sets. In your example, there was a 4 number match between sets 10 and 19.
|