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]

@Peter_SSs, the changes will only speed it up if there are a fair proportion of 5 and 4 matches.
You are right of course as long as my dictionary key was consistent I could have left the leading |. Also thanks for the reminder on the VBA mid, I keep forgetting it works differently to the Excel mid function.

 

[motilulla]

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.

Hello Peter_SSs, I am so happy to get result in 00:0014 Minutes.

Yes the 148 result are multiplied by 9 to reach 1332 for trail. But your VBA results have accurate matches.

When I run only with 1 result keeping K6:O6 line (eliminating rest all) highlighting the below line in yellow and give an error “9” please can you take a look.

If a(i, k) = b(j, x) Then

I appreciate your kind help.

Have a good day nice start of the week ahead and Good Luck.

Regards,
Moti

 

[motilulla]

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.

Hello Alex Blakenburg, I am so happy to get result in 00:0012 Minutes.

When I run only with 1 result keeping K6:O6 line (eliminating rest all) highlighting the below line in yellow and give an error “9” please can you take a look.

If a(i, k) = b(j, x) Then

I appreciate your kind help.

Have a good day nice start of the week ahead and Good Luck.

Regards,
Moti

 

[Peter_SSs]

When I run only with 1 result keeping K6:O6 line (eliminating rest all) highlighting the below line in yellow and give an error “9” please can you take a look.

I'm not sure why you would run it with only 1 result. Surely you wouldn't be making any decisions on the basis of 1 result?

Still if you want to do that, try this slight change about 1/3 of the way down in my code or in Alex's modification.

Sub VBA_MultiLotteryChecker_v3()
  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 + 1
  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

 

[motilulla]

I'm not sure why you would run it with only 1 result. Surely you wouldn't be making any decisions on the basis of 1 result?

Still if you want to do that, try this slight change about 1/3 of the way down in my code or in Alex's modification.

Hello Peter_SSs, all is working as I wanted fast and impeccable. I am happy.

I am very grateful to you for your kind help.

Good day and Good Luck.

Kind Regards,
Moti

 

[Peter_SSs]

You're welcome. Glad we could help. Thanks for the follow-up.