Need Faster VBA, For Lottery Checker

[motilulla]

Using Excel 2010
Hello,

Here is example with 95 rows in the range B6:F53135 I have a set of 5 numbers combinations and in the range K6:O1332 I have a sets of results. (I want to check all the result against all combinations)

For that I am have formula in cell H3 below which have converted into VBA. The below VBA give me the results in cell H6 to down.

The problem when there is combination with 53130 rows and results with 1332 rows it is taking too much time (approximately 00:02:30 Minutes) to populate the results in the column H.

Please I need a help is there any fast VBA version to solve the time issue.

Here is below the example sheet with formula and VBA which I am using are attached.

Excel Questions.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1
2
3								5
4		53130	53130	53130	53130	53130					1332	1332	1332	1332	1332
5	Combi	n1	n2	n3	n4	n5		Match Results		Result	n1	n2	n3	n4	n5
6	1	1	2	3	4	5		5		1	1	2	3	4	5
7	2	1	2	3	4	6		4		2	1	2	6	7	8
8	3	1	2	3	4	7		4		3	1	2	9	10	11
9	4	1	2	3	4	8		4		4	1	2	12	13	14
10	5	1	2	3	4	9		4		5	1	2	15	16	17
11	6	1	2	3	4	10		4		6	1	2	18	19	20
12	7	1	2	3	4	11		4		7	1	2	21	22	23
13	8	1	2	3	4	12		4		8	1	3	6	9	12
14	9	1	2	3	4	13		4		9	1	3	7	10	13
15	10	1	2	3	4	14		4		10	1	3	8	11	14
16	11	1	2	3	4	15		4		11	1	3	15	18	21
17	12	1	2	3	4	16		4		12	1	3	16	19	22
18	13	1	2	3	4	17		4		13	1	3	17	20	23
19	14	1	2	3	4	18		4		14	1	4	6	10	14
20	15	1	2	3	4	19		4		15	1	4	7	9	15
21	16	1	2	3	4	20		4		16	1	4	8	12	16
22	17	1	2	3	4	21		4		17	1	4	11	13	17
23	18	1	2	3	4	22		4		18	1	4	18	22	24
24	19	1	2	3	4	23		4		19	1	4	19	21	25
25	20	1	2	3	4	24		4		20	1	5	6	11	15
26	21	1	2	3	4	25		4		21	1	5	7	12	17
27	22	1	2	3	5	6		4		22	1	5	8	9	13
28	23	1	2	3	5	7		4		23	1	5	10	16	18
29	24	1	2	3	5	8		4		24	1	5	14	19	23
30	25	1	2	3	5	9		4		25	1	5	20	21	24
31	26	1	2	3	5	10		4		26	1	6	13	16	20
32	27	1	2	3	5	11		4		27	1	6	17	18	25
33	28	1	2	3	5	12		4		28	1	7	11	16	21
34	29	1	2	3	5	13		4		29	1	7	14	20	22
35	30	1	2	3	5	14		4		30	1	7	23	24	25
36	31	1	2	3	5	15		4		31	1	8	10	15	19
37	32	1	2	3	5	16		4		32	1	9	14	16	24
38	33	1	2	3	5	17		4		33	1	10	12	20	25
39	34	1	2	3	5	18		4		34	1	11	12	18	23
40	35	1	2	3	5	19		4		35	1	13	15	22	25
41	36	1	2	3	5	20		4		36	2	3	6	10	15
42	37	1	2	3	5	21		4		37	2	3	7	9	14
43	38	1	2	3	5	22		4		38	2	3	8	12	17
44	39	1	2	3	5	23		4		39	2	3	11	13	16
45	40	1	2	3	5	24		4		40	2	3	18	22	25
46	41	1	2	3	5	25		4		41	2	3	19	21	24
47	42	1	2	3	6	7		4		42	2	4	6	9	13
48	43	1	2	3	6	8		4		43	2	4	7	10	12
49	44	1	2	3	6	9		4		44	2	4	8	11	15
50	45	1	2	3	6	10		4		45	2	4	14	16	18
51	46	1	2	3	6	11		3		46	2	4	17	19	22
52	47	1	2	3	6	12		4		47	2	4	20	23	24
53	48	1	2	3	6	13		3		48	2	5	6	12	16
54	49	1	2	3	6	14		3		49	2	5	7	11	18
55	50	1	2	3	6	15		4		50	2	5	8	10	14
56	51	1	2	3	6	16		3		51	2	5	9	15	19
57	52	1	2	3	6	17		3		52	2	5	13	17	20
58	53	1	2	3	6	18		3		53	2	6	11	14	17
59	54	1	2	3	6	19		3		54	2	6	19	23	25
60	55	1	2	3	6	20		3		55	2	7	13	15	21
61	56	1	2	3	6	21		3		56	2	7	16	20	25
62	57	1	2	3	6	22		3		57	2	8	9	16	21
63	58	1	2	3	6	23		3		58	2	8	13	18	23
64	59	1	2	3	6	24		3		59	2	9	12	18	24
65	60	1	2	3	6	25		3		60	2	10	13	22	24
66	61	1	2	3	7	8		4		61	2	10	17	18	21
67	62	1	2	3	7	9		4		62	2	11	12	20	21
68	63	1	2	3	7	10		4		63	2	14	15	24	25
69	64	1	2	3	7	11		3		64	3	4	6	7	11
70	65	1	2	3	7	12		3		65	3	4	8	9	10
71	66	1	2	3	7	13		4		66	3	4	12	13	15
72	67	1	2	3	7	14		4		67	3	4	14	17	21
73	68	1	2	3	7	15		3		68	3	4	16	23	25
74	69	1	2	3	7	16		3		69	3	5	6	8	18
75	70	1	2	3	7	17		3		70	3	5	7	15	16
76	71	1	2	3	7	18		3		71	3	5	9	11	17
77	72	1	2	3	7	19		3		72	3	5	10	12	19
78	73	1	2	3	7	20		3		73	3	5	13	14	22
79	74	1	2	3	7	21		3		74	3	6	13	17	19
80	75	1	2	3	7	22		3		75	3	6	14	20	24
81	76	1	2	3	7	23		3		76	3	7	8	19	20
82	77	1	2	3	7	24		3		77	3	7	12	21	22
83	78	1	2	3	7	25		3		78	3	7	17	18	24
84	79	1	2	3	8	9		3		79	3	8	13	21	25
85	80	1	2	3	8	10		3		80	3	8	15	22	23
86	81	1	2	3	8	11		4		81	3	9	13	18	20
87	82	1	2	3	8	12		4		82	3	10	11	20	22
88	83	1	2	3	8	13		3		83	3	10	14	18	23
89	84	1	2	3	8	14		4		84	3	11	12	24	25
90	85	1	2	3	8	15		3		85	4	5	6	17	23
91	86	1	2	3	8	16		3		86	4	5	7	8	21
92	87	1	2	3	8	17		4		87	4	5	9	12	14
93	88	1	2	3	8	18		3		88	4	5	10	11	24
94	89	1	2	3	8	19		3		89	4	5	13	16	19
95	90	1	2	3	8	20		3		90	4	5	15	18	20
96	91	1	2	3	8	21		3		91	4	6	8	19	24
97	92	1	2	3	8	22		3		92	4	6	12	18	21
98	93	1	2	3	8	23		3		93	4	6	15	16	22
99	94	1	2	3	8	24		3		94	4	7	13	14	23
100	95	1	2	3	8	25		3		95	4	8	13	20	22
Sheet Lottery

Cell Formulas
Range	Formula
H3	H3	=MAX(MMULT(COUNTIF(B6:F6,K$6:O$53135),{1;1;1;1;1}))
K4:O4,B4:F4	B4	=COUNTA(B6:B53135)
A7:A100	A7	=A6+1
Press CTRL+SHIFT+ENTER to enter array formulas.

Option Explicit
Sub VBA_MultiLotteryChecker()
    
    Range("H6:H53135").ClearContents
    
    Dim startTime As Double
    Dim MinutesElapsed As String
    startTime = Timer
    
Dim a, b, c
Dim i As Long, j As Long, k As Long, n As Long, Lr As Long, l As Long
Dim xmax As Long

Application.ScreenUpdating = False

Lr = Cells(Rows.Count, "B").End(xlUp).row
a = Range("B6:H" & Lr)
ReDim c(1 To Lr)
Lr = Cells(Rows.Count, "K").End(xlUp).row
b = Range("K2:O" & Lr)

For i = 1 To UBound(a, 1)
    xmax = 0
    For j = 1 To UBound(b, 1)
        n = 0
        For k = 1 To 5
            For l = 1 To 5
                If a(i, k) = b(j, l) Then
                    n = n + 1
                    Exit For
                End If
            Next l
        Next k
          
           If n > xmax Then
                xmax = n
            End If

        Next j
    
    c(i) = xmax
Next i

[H6].Resize(UBound(c, 1), 1) = Application.Transpose(c)

Application.ScreenUpdating = True

   MinutesElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
   MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

Regards,
Moti

 

[Alex Blakenburg]

Any reason you didn't use the code I gave you the last time ?
Also some of your results in your sample data look wrong to me based on the sample data, perhaps you ran it on the full data set.

Here is the code I gave you previously modified for only 5 combinations instead of the previous 14

Sub VBA_MultiLotteryChecker()
    Dim startTime As Double
    startTime = Timer
   
    Dim a, b, c
    Dim i As Long, j As Long, k As Long, n As Long, m As Long
    Dim Lr As Long, xmax As Long
    Dim iPossible As Long, iMiss As Long, xMiss As Long
   
    Lr = Cells(Rows.Count, "H").End(xlUp).Row
    Range("H6:H" & Lr).ClearContents
   
    Application.ScreenUpdating = False
   
    Lr = Cells(Rows.Count, "B").End(xlUp).Row
    a = Range("B6:F" & Lr)
    ReDim c(1 To Lr, 1 To 1)
    Lr = Cells(Rows.Count, "K").End(xlUp).Row
    b = Range("K6:O" & Lr)
   
    iPossible = UBound(b, 2)
   
    For i = 1 To UBound(a, 1)
        xmax = 0
        xMiss = iPossible
       
        For j = 1 To UBound(b, 1)
            n = 0
            iMiss = 0
            For k = 1 To 5
                If a(i, k) = b(j, k) Then
                    n = n + 1
                Else
                    ' if more misses than the best so far no point in looking further
                    iMiss = iMiss + 1
                    If iMiss > xMiss Then Exit For
                End If
            Next k
           
            If n > xmax Then
                xmax = n
                xMiss = iPossible - xmax
            End If
            ' if iPossible is reached no point looking further
            If xmax = iPossible Then Exit For
        Next j
      
        c(i, 1) = xmax
    Next i
    
    Range("H6").Resize(UBound(c, 1), 1) = c
   
    Application.ScreenUpdating = True
   
    Debug.Print Timer - startTime
     
End Sub

 

[motilulla]

Any reason you didn't use the code I gave you the last time ?

Alex Blakenburg, Please not at all that is working like magic. As you will see that VBA was converted from the following formula

=MAX(MMULT(--($U$6:$AH$20000=B6:O6),TRANSPOSE(COLUMN($U$6:$AH$6))^0))

Also some of your results in your sample data look wrong to me based on the sample data, perhaps you ran it on the full data set.

You have reason that is not correct. I ran it on full data.

Here is the code I gave you previously modified for only 5 combinations instead of the previous 14

This is another issue Post#1 VBA is converted from the following formula.

=MAX(MMULT(COUNTIF(B6:F6,K$6:O$53135),{1;1;1;1;1}))

May be it needs another look at it?


I tried your code and change the lines to get results in Column I...Instead of H

Lr = Cells(Rows.Count, "I").End(xlUp).row
    Range("I6:I" & Lr).ClearContents

Range("I6").Resize(UBound(c, 1), 1) = c

Here are exact results from both macros
Post#1 (VBA_MultiLotteryChecker_1)
And you’re from Post#2 (VBA_MultiLotteryChecker_2)

The post#1code result is correct in the column H, on actual data. Matches results are shown in the Q6:Q11

The post#2code result is in column I, on actual data. Which does not match with column H, Matches results are shown in the Q16:Q21? I guess because both formulas are different…for more conformation you can run the Formula if require.

Here below is sheet attached with all actual layout results. Reduced the data 95 to 92, Xl2bb does not copy.

Excel VBA Questions.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2
3								5								Match	Result
4		92	92	92	92	92		Macro_1	Macro_2		92	92	92	92	92	Match	Macro_1
5	Combi	n1	n2	n3	n4	n5		Match Results	Match Results	Result	n1	n2	n3	n4	n5	Match	92
6	1	1	2	3	4	5		5	5	1	1	2	3	4	5	5	1
7	2	1	2	3	4	6		4	4	2	1	2	6	7	8	4	55
8	3	1	2	3	4	7		4	4	3	1	2	9	10	11	3	36
9	4	1	2	3	4	8		4	4	4	1	2	12	13	14	2	0
10	5	1	2	3	4	9		4	4	5	1	2	15	16	17	1	0
11	6	1	2	3	4	10		4	4	6	1	2	18	19	20	0	0
12	7	1	2	3	4	11		4	4	7	1	2	21	22	23
13	8	1	2	3	4	12		4	4	8	1	3	6	9	12	Match	Result
14	9	1	2	3	4	13		4	4	9	1	3	7	10	13	Match	Macro_2
15	10	1	2	3	4	14		4	4	10	1	3	8	11	14	Match	92
16	11	1	2	3	4	15		4	4	11	1	3	15	18	21	5	1
17	12	1	2	3	4	16		4	4	12	1	3	16	19	22	4	21
18	13	1	2	3	4	17		4	4	13	1	3	17	20	23	3	70
19	14	1	2	3	4	18		4	4	14	1	4	6	10	14	2	0
20	15	1	2	3	4	19		4	4	15	1	4	7	9	15	1	0
21	16	1	2	3	4	20		4	4	16	1	4	8	12	16	0	0
22	17	1	2	3	4	21		4	4	17	1	4	11	13	17
23	18	1	2	3	4	22		4	4	18	1	4	18	22	24
24	19	1	2	3	4	23		4	4	19	1	4	19	21	25
25	20	1	2	3	4	24		4	4	20	1	5	6	11	15
26	21	1	2	3	4	25		4	4	21	1	5	7	12	17
27	22	1	2	3	5	6		4	3	22	1	5	8	9	13
28	23	1	2	3	5	7		4	3	23	1	5	10	16	18
29	24	1	2	3	5	8		4	3	24	1	5	14	19	23
30	25	1	2	3	5	9		4	3	25	1	5	20	21	24
31	26	1	2	3	5	10		4	3	26	1	6	13	16	20
32	27	1	2	3	5	11		4	3	27	1	6	17	18	25
33	28	1	2	3	5	12		4	3	28	1	7	11	16	21
34	29	1	2	3	5	13		4	3	29	1	7	14	20	22
35	30	1	2	3	5	14		4	3	30	1	7	23	24	25
36	31	1	2	3	5	15		4	3	31	1	8	10	15	19
37	32	1	2	3	5	16		4	3	32	1	9	14	16	24
38	33	1	2	3	5	17		4	3	33	1	10	12	20	25
39	34	1	2	3	5	18		4	3	34	1	11	12	18	23
40	35	1	2	3	5	19		4	3	35	1	13	15	22	25
41	36	1	2	3	5	20		4	3	36	2	3	6	10	15
42	37	1	2	3	5	21		4	3	37	2	3	7	9	14
43	38	1	2	3	5	22		4	3	38	2	3	8	12	17
44	39	1	2	3	5	23		4	3	39	2	3	11	13	16
45	40	1	2	3	5	24		4	3	40	2	3	18	22	25
46	41	1	2	3	5	25		4	3	41	2	3	19	21	24
47	42	1	2	3	6	7		4	3	42	2	4	6	9	13
48	43	1	2	3	6	8		4	3	43	2	4	7	10	12
49	44	1	2	3	6	9		4	3	44	2	4	8	11	15
50	45	1	2	3	6	10		4	3	45	2	4	14	16	18
51	46	1	2	3	6	11		3	3	46	2	4	17	19	22
52	47	1	2	3	6	12		4	3	47	2	4	20	23	24
53	48	1	2	3	6	13		3	3	48	2	5	6	12	16
54	49	1	2	3	6	14		3	3	49	2	5	7	11	18
55	50	1	2	3	6	15		4	3	50	2	5	8	10	14
56	51	1	2	3	6	16		3	3	51	2	5	9	15	19
57	52	1	2	3	6	17		3	3	52	2	5	13	17	20
58	53	1	2	3	6	18		3	3	53	2	6	11	14	17
59	54	1	2	3	6	19		3	3	54	2	6	19	23	25
60	55	1	2	3	6	20		3	3	55	2	7	13	15	21
61	56	1	2	3	6	21		3	3	56	2	7	16	20	25
62	57	1	2	3	6	22		3	3	57	2	8	9	16	21
63	58	1	2	3	6	23		3	3	58	2	8	13	18	23
64	59	1	2	3	6	24		3	3	59	2	9	12	18	24
65	60	1	2	3	6	25		3	3	60	2	10	13	22	24
66	61	1	2	3	7	8		4	4	61	2	10	17	18	21
67	62	1	2	3	7	9		4	3	62	2	11	12	20	21
68	63	1	2	3	7	10		4	3	63	2	14	15	24	25
69	64	1	2	3	7	11		3	3	64	3	4	6	7	11
70	65	1	2	3	7	12		3	3	65	3	4	8	9	10
71	66	1	2	3	7	13		4	3	66	3	4	12	13	15
72	67	1	2	3	7	14		4	3	67	3	4	14	17	21
73	68	1	2	3	7	15		3	3	68	3	4	16	23	25
74	69	1	2	3	7	16		3	3	69	3	5	6	8	18
75	70	1	2	3	7	17		3	3	70	3	5	7	15	16
76	71	1	2	3	7	18		3	3	71	3	5	9	11	17
77	72	1	2	3	7	19		3	3	72	3	5	10	12	19
78	73	1	2	3	7	20		3	3	73	3	5	13	14	22
79	74	1	2	3	7	21		3	3	74	3	6	13	17	19
80	75	1	2	3	7	22		3	3	75	3	6	14	20	24
81	76	1	2	3	7	23		3	3	76	3	7	8	19	20
82	77	1	2	3	7	24		3	3	77	3	7	12	21	22
83	78	1	2	3	7	25		3	3	78	3	7	17	18	24
84	79	1	2	3	8	9		3	3	79	3	8	13	21	25
85	80	1	2	3	8	10		3	3	80	3	8	15	22	23
86	81	1	2	3	8	11		4	3	81	3	9	13	18	20
87	82	1	2	3	8	12		4	3	82	3	10	11	20	22
88	83	1	2	3	8	13		3	3	83	3	10	14	18	23
89	84	1	2	3	8	14		4	3	84	3	11	12	24	25
90	85	1	2	3	8	15		3	3	85	4	5	6	17	23
91	86	1	2	3	8	16		3	3	86	4	5	7	8	21
92	87	1	2	3	8	17		4	3	87	4	5	9	12	14
93	88	1	2	3	8	18		3	3	88	4	5	10	11	24
94	89	1	2	3	8	19		3	3	89	4	5	13	16	19
95	90	1	2	3	8	20		3	3	90	4	5	15	18	20
96	91	1	2	3	8	21		3	3	91	4	6	8	19	24
97	92	1	2	3	8	22		3	3	92	4	6	12	18	21
Sheet Lottery-Test

Cell Formulas
Range	Formula
H3	H3	=MAX(MMULT(COUNTIF(B6:F6,K$6:O$97),{1;1;1;1;1}))
K4:O4,B4:F4	B4	=COUNTA(B6:B97)
Q5,Q15	Q5	=SUM(Q6:Q11)
Q6:Q11	Q6	=COUNTIF(H$6:H$97,P6)
Q16:Q21	Q16	=COUNTIF(I$6:I$97,P16)
Press CTRL+SHIFT+ENTER to enter array formulas.

Regards,
Moti

 

[Alex Blakenburg]

I assume the logic is exactly the same as for the 14 columns right ?
Can you post the whole sheet using Dropbox, Google drive, OneDrive ... and make sure anyone with the link can access it.
.
For item 22 on the left you are saying you get 4 while my macro is returning 3 but I can find nothing in the right hand side that would give you 4

PS: I am signing off for the night

 

[kvsrinivasamurthy]

Try this code.
I avoided unnecessary Trail of matchings. It is assumed as given in file that in both tables in each row numbe.rs are in ascending order.

Sub VBA_MultiLotteryChecker()
    
    Range("H6:H53135").ClearContents
    
    Dim startTime As Double
    Dim MinutesElapsed As String
    startTime = Timer
    
Dim a, b, c
Dim i As Long, j As Long, k As Long, n As Long, Lr As Long, l As Long
Dim xmax As Long, Z As Long

Application.ScreenUpdating = False

Lr = Cells(Rows.Count, "B").End(xlUp).Row
a = Range("B6:H" & Lr)
ReDim c(1 To Lr)
Lr = Cells(Rows.Count, "K").End(xlUp).Row
b = Range("K6:O" & Lr)

For i = 1 To UBound(a, 1)
    xmax = 0
    For j = 1 To UBound(b, 1)
        n = 0: Z = 1
        For k = 1 To 5
            For l = Z To 5
                If a(i, k) = b(j, l) Then
                    n = n + 1: Z = l
                    Exit For
                ElseIf a(i, k) < b(j, l) Then
                    Z = l: Exit For
                End If
            Next l
        Next k
          
           If n > xmax Then
                xmax = n
            End If

        Next j
    
    c(i) = xmax
Next i

[H6].Resize(UBound(c, 1), 1) = Application.Transpose(c)

Application.ScreenUpdating = True

   MinutesElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
   MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

 

[motilulla]

Try this code.
I avoided unnecessary Trail of matchings. It is assumed as given in file that in both tables in each row numbe.rs are in ascending order.

Hello kvsrinivasamurthy, respect to code post#1, your code finishes 25 second early, within 00:02:05 minutes. It is better, but I wonder could it be faster?

Thank you for your help.

Kind Regards,
Moti

 

[motilulla]

I assume the logic is exactly the same as for the 14 columns right ?
Can you post the whole sheet using Dropbox, Google drive, OneDrive ... and make sure anyone with the link can access it.
.
For item 22 on the left you are saying you get 4 while my macro is returning 3 but I can find nothing in the right hand side that would give you 4

PS: I am signing off for the night

View attachment 107016

Hello Alex Blakenburg, i have uploaded whole file using Dropbox here is the link below hope you can down load it. Column G has the result by Formula and column H result by VBA which take 00:02:30 Minutes

VBA Multi Lottery Checker.xlsm

I am not expert but I guess previous VBA check 14 columns against 14 columns but in serial for example 1-X-2 if in other side is 1-2-X this is one match only 1 to 1, X to 2 not match, 2 To X also does not match.

But this may is different also noticed this check only numbers, other has text and numbers. may i am wrong.

Have a good weekend

Regards,
Moti

 

[Peter_SSs]

On my machine with your sample workbook the time reduced from 2:53 using the code in the workbook to 0:16 using the code below.
That is a significant reduction however I am not sure that your sample workbook is indicative of actual data since the 'Results' section appears to be multiple copies of the same set of 148 results. Therefore I don't expect my code to be as much faster on real data, though there are a few minor speed enhancements in it. Anyway, you can give it a try.

Sub VBA_MultiLotteryChecker_v2()
  Dim startTime As Double
  Dim MinutesElapsed As String
  startTime = Timer
      
  Dim d As Object
  Dim s As String
  Dim a, b, c
  Dim i As Long, j As Long, k As Long, n As Long, Lr As Long, x As Long
  Dim xmax As Long, startcol As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  Range("H6:H53135").ClearContents
  Lr = Cells(Rows.Count, "B").End(xlUp).row
  a = Range("B6:F" & Lr)
  
  Lr = Cells(Rows.Count, "K").End(xlUp).row
  b = Range("K6:O" & Lr)

  For i = 1 To UBound(b)
    s = Join(Application.Index(b, i, 0), "|")
    If Not d.exists(s) Then d(s) = i
  Next i
  b = Application.Index(b, Application.Transpose(d.Items), Array(1, 2, 3, 4, 5))
  ReDim c(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a, 1)
    xmax = 0
    For j = 1 To UBound(b, 1)
      n = 0
      startcol = 1
      For k = 1 To 5
        For x = startcol To 5
          If a(i, k) = b(j, x) Then
            n = n + 1
            startcol = x + 1
            Exit For
          End If
        Next x
      Next k
      If n > xmax Then xmax = n
    Next j
    c(i, 1) = xmax
  Next i
  Range("H6").Resize(UBound(c), 1).Value = c
  Application.ScreenUpdating = True

  MinutesElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
  MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub

 

[Alex Blakenburg]

In the sample data the numbers in the rows are sorted in ascending order, if this can be relied on then the below modification of Peter's code might take a little bit more off the time.

Sub VBA_MultiLotteryChecker_v2_PeterMod()
  Dim startTime As Double
  Dim MinutesElapsed As String
  startTime = Timer
      
  Dim d As Object
  Dim s As String
  Dim a, b, c
  Dim i As Long, j As Long, k As Long, n As Long, Lr As Long, x As Long
  Dim xmax As Long, startcol As Long
  Dim m As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  Lr = Cells(Rows.Count, "H").End(xlUp).Row
  Range("H6:H" & Lr).ClearContents
  Lr = Cells(Rows.Count, "B").End(xlUp).Row
  a = Range("B6:F" & Lr)
  Dim maxcols As Long
  maxcols = UBound(a, 2)
  
  Lr = Cells(Rows.Count, "K").End(xlUp).Row
  b = Range("K6:O" & Lr)

  For i = 1 To UBound(b)
    s = ""
    For m = 1 To maxcols
        s = s & "|" & b(i, m)
    Next m
    s = Right(s, Len(s) - 1)    
    If Not d.exists(s) Then d(s) = i
  Next i
  b = Application.Index(b, Application.Transpose(d.Items), Array(1, 2, 3, 4, 5))
  ReDim c(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a, 1)
    xmax = 0
    ' Check if exact result exists - assumes both rows are sorted in ascending order
    s = ""
    For m = 1 To maxcols
        s = s & "|" & a(i, m)
    Next m
    s = Right(s, Len(s) - 1)
    If d.exists(s) Then
        xmax = maxcols
    Else
        
        For j = 1 To UBound(b, 1)
          n = 0
          startcol = 1
          For k = 1 To 5
            For x = startcol To 5
              If a(i, k) = b(j, x) Then
                n = n + 1
                startcol = x + 1
                Exit For
              End If
            Next x
          Next k
          If n > xmax Then xmax = n
          ' Since we have checked for a 5 max then next possible is 4
          If xmax = 4 Then Exit For
        Next j
    End If
    c(i, 1) = xmax
  Next i
  Range("H6").Resize(UBound(c), 1).Value = c
  Application.ScreenUpdating = True

  MinutesElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
  MsgBox "AB This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub

 

[Peter_SSs]

In the sample data the numbers in the rows are sorted in ascending order, if this can be relied on then the below modification of Peter's code might take a little bit more off the time.

Hi Alex, Yes that could be marginally faster, depending on the results section contents.
BTW,

• My code was already dependant on both sets of data having each row in ascending order
• The difference would be minimal but I don't think there is any need to strip the first "|" off s is there?
  If there is, then simpler than s = Right(s, Len(s) - 1) would be s = Mid(s, 2)