Loop set of 3, within 5 results

[motilulla]

Using Excel 2010

Hello, I got lottery results in column D:H approximately 2000+ rows, and set of triples in column K:M, I need a VBA which can loop set of 3… through column D:H and generate the count result in column O as shown in small example below

Count Triples And Find Dealy MrExcel.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1
2															Results
3															Need VBA
4		Draw S.N		Results											To Count
5		Draw S.N		n1	n2	n3	n4	n5			Triples			Join Triples	Triples
6		1	13/02/2004	16	29	32	36	41			16	29	32	16 | 29 | 32	2
7		2	20/02/2004	16	13	29	32	50			1	2	5	1 | 2 | 5	3
8		3	27/02/2004	01	02	05	31	37			1	2	26	1 | 2 | 26	0
9		4	05/03/2004	01	02	04	05	39			1	4	16	1 | 4 | 16	0
10		5	12/03/2004	15	24	28	44	47			1	4	37	1 | 4 | 37	0
11		6	19/03/2004	33	36	37	42	45			1	5	21	1 | 5 | 21	1
12		7	26/03/2004	03	04	10	23	43			2	7	8	2 | 7 | 8	0
13		8	02/04/2004	04	12	24	27	36			6	29	48	6 | 29 | 48	0
14		9	09/04/2004	01	05	21	19	23			7	22	48	7 | 22 | 48	0
15		10	16/04/2004	01	02	03	04	05			9	12	25	9 | 12 | 25	0
16		11	23/04/2004	06	10	21	45	49			15	18	22	15 | 18 | 22	2
17		12	30/04/2004	05	06	16	23	27			24	27	32	24 | 27 | 32	0
18		13	07/05/2004	15	16	21	36	38			16	29	32	16 | 29 | 32	2
19		14	14/05/2004	01	03	21	32	39			1	2	5	1 | 2 | 5	3
20		15	21/05/2004	15	29	37	39	49			1	2	26	1 | 2 | 26	0
21		16	28/05/2004	06	11	35	41	44			1	4	16	1 | 4 | 16	0
22		17	04/06/2004	09	13	34	41	42			1	4	37	1 | 4 | 37	0
23		18	11/06/2004	15	18	22	10	47			1	5	21	1 | 5 | 21	1
24		19	18/06/2004	02	23	28	40	43			2	7	8	2 | 7 | 8	0
25		20	25/06/2004	03	21	30	34	35			6	29	48	6 | 29 | 48	0
26		21	02/07/2004	04	23	24	28	34			7	22	48	7 | 22 | 48	0
27		22	09/07/2004	15	16	18	19	22			9	12	25	9 | 12 | 25	0
28		23	16/07/2004	24	26	31	38	50			15	18	22	15 | 18 | 22	2
29		24	23/07/2004	07	10	27	31	34			24	27	32	24 | 27 | 32	0
30		25	30/07/2004	09	10	19	37	50			16	29	32	16 | 29 | 32	2
31		26	06/08/2004	05	15	24	35	44			1	2	5	1 | 2 | 5	3
32		27	13/08/2004	20	27	41	43	50			1	2	26	1 | 2 | 26	0
33		28	20/08/2004	06	09	10	27	35			1	4	16	1 | 4 | 16	0
34		29	27/08/2004	01	11	22	28	44			1	4	37	1 | 4 | 37	0
35
36
Sheet1

Regards,
Moti

 

[Peter_SSs]

Give this a try. I have assumed that the leading zeros in columns D:H (eg "01") are the result of the cell formatting and that the underlying number in the cell is 1.

Sub Count_Triples()
  Dim RX As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  a = Range("D6", Range("H" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    a(i, 1) = ":" & Join(Application.Index(a, i, 0), "::") & ":"
  Next i
  b = Range("K6", Range("M" & Rows.Count).End(xlUp)).Value
  ReDim c(1 To UBound(b), 1 To 1)
  For i = 1 To UBound(b)
    RX.Pattern = ":" & b(i, 1) & ":|:" & b(i, 2) & ":|:" & b(i, 3) & ":"
    c(i, 1) = 0
    For j = 1 To UBound(a)
      If RX.Execute(a(j, 1)).Count = 3 Then c(i, 1) = c(i, 1) + 1
    Next j
  Next i
  Range("O6").Resize(UBound(c)).Value = c
End Sub

 

[motilulla]

Give this a try. I have assumed that the leading zeros in columns D:H (eg "01") are the result of the cell formatting and that the underlying number in the cell is 1.

Hello Peter_SSs, VBA results are spot-on. I appreciate your time and help. Good luck.

I tried to modify code to count quads but no luck, need your help once again please can you take a look and modify the code so it could work with the following data. I have removed the cell formatting and it is set to general

Count Triples And Find Dealy MrExcel.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1
2															Results
3															Need VBA
4		Draw S.N		Results											To Count
5		Draw S.N		n1	n2	n3	n4	n5			Cuads				Quads
6		1	13/02/2004	16	29	32	36	41			1	2	3	4	0
7		2	20/02/2004	7	13	39	47	50			1	2	5	31	0
8		3	27/02/2004	14	18	19	31	37			1	2	26	31	0
9		4	05/03/2004	4	7	33	37	39			1	4	16	5	0
10		5	12/03/2004	15	24	28	44	47			1	4	37	44	0
11		6	19/03/2004	33	36	37	42	45			1	3	21	32	1
12		7	26/03/2004	3	4	10	23	43			2	7	8	23	0
13		8	02/04/2004	4	12	24	27	36			6	29	48	27	0
14		9	09/04/2004	1	4	10	19	23			7	22	48	19	0
15		10	16/04/2004	14	15	28	35	40			9	12	25	4	0
16		11	23/04/2004	6	10	21	45	49			15	18	22	45	0
17		12	30/04/2004	5	6	16	23	27			24	27	32	23	0
18		13	07/05/2004	15	16	21	36	38			16	29	32	36	1
19		14	14/05/2004	1	3	21	32	39			1	2	5	32	0
20		15	21/05/2004	15	29	37	39	49			1	2	26	39	0
21		16	28/05/2004	6	11	35	41	44			1	4	16	41	0
22		17	04/06/2004	9	13	34	41	42			5	15	24	35	1
23		18	11/06/2004	2	7	8	10	47			1	5	21	10	0
24		19	18/06/2004	2	23	28	40	43			2	7	8	40	0
25		20	25/06/2004	3	21	30	34	35			6	29	48	34	0
26		21	02/07/2004	4	23	24	28	34			7	22	48	28	0
27		22	09/07/2004	2	5	12	19	44			9	12	25	19	0
28		23	16/07/2004	24	26	31	38	50			15	18	22	38	0
29		24	23/07/2004	7	10	27	31	34			24	27	32	31	0
30		25	30/07/2004	9	10	19	37	50			16	29	32	37	0
31		26	06/08/2004	5	15	24	35	44			1	2	5	35	0
32		27	13/08/2004	20	27	41	43	50			1	2	26	43	0
33		28	20/08/2004	6	9	10	27	35			1	4	10	19	1
34		29	27/08/2004	1	11	22	28	44			1	4	37	28	0
35
36
Sheet2

Best Regards,
Moti

 

[Peter_SSs]

I tried to modify code to count quads ..

This code should count any number of multiples by changing the 'Const' line near the start. Also change the "O6" near the end, if required, to be the top cell of where the results should go.

Option Explicit

Sub Count_Multiples()
  Dim RX As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
 
  Const Multiples As Long = 4 '<- 2 for doubles, 3 for triples etc
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  a = Range("D6", Range("H" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    a(i, 1) = ":" & Join(Application.Index(a, i, 0), "::") & ":"
  Next i
  b = Range("K6", Range("K" & Rows.Count).End(xlUp)).Resize(, Multiples).Value
  ReDim c(1 To UBound(b), 1 To 1)
  For i = 1 To UBound(b)
    RX.Pattern = ":" & Join(Application.Index(b, i, 0), ":|:") & ":"
    c(i, 1) = 0
    For j = 1 To UBound(a)
      If RX.Execute(a(j, 1)).Count = Multiples Then c(i, 1) = c(i, 1) + 1
    Next j
  Next i
  Range("O6").Resize(UBound(c)).Value = c
End Sub

 

[motilulla]

This code should count any number of multiples by changing the 'Const' line near the start. Also change the "O6" near the end, if required, to be the top cell of where the results should go.

Hello Peter_SSs, thank you for modifying code to count any number of multiples by changing the 'Const'

Here are my test results….
1st Post#2 macro “Sub Count_Triples()” when I tried with my original data as per post#1 layout with 1700+ rows result in columns D:H and 19000+ triples in the column K:M it took 68 seconds and when I tried Post#4 macro “Sub Count_Multiples()” changing 'Const' 3 it took time to finish 129 second just double than post#2 macro.

2nd post#4 macro “Sub Count_Multiples()” when I tried with my original data as per post#3 layout with 1700+ rows result in column D:H and 65000+ quads in the column K:N it blocked my computer (I create new workbook and tried several times but each time I need to reset computer) and the post#2 code cannot tried because it does not count quads.

Please I would like would you try it does it work with your computer, or may be this issue is my side only. I am running window 10 Pro. RAM 16,0 GB. Processor ntel(R) Core(TM) i7-6700 CPU @ 3.40GHz 3.40 GHz

Best Regards,
Moti

 

[Peter_SSs]

Please I would like would you try it does it work with your computer,

I don't have any suitable data to test it with. However, I'm not surprised that it takes a long time (or fails) with the amount of data you are telling us about.
For example ..

I tried with my original data as per post#3 layout with 1700+ rows result in column D:H and 65000+ quads in the column K:N

Here there are 260,000 numbers in K:N and 10,200 in D:H. That gives a possible number of comparisons of 2,652,000,000
There may be a way to shorten it but nothing is obvious to me to make it a lot faster.

 

[motilulla]

Give this a try. I have assumed that the leading zeros in columns D:H (eg "01") are the result of the cell formatting and that the underlying number in the cell is 1.

Sub Count_Triples()
  Dim RX As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  a = Range("D6", Range("H" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    a(i, 1) = ":" & Join(Application.Index(a, i, 0), "::") & ":"
  Next i
  b = Range("K6", Range("M" & Rows.Count).End(xlUp)).Value
  ReDim c(1 To UBound(b), 1 To 1)
  For i = 1 To UBound(b)
    RX.Pattern = ":" & b(i, 1) & ":|:" & b(i, 2) & ":|:" & b(i, 3) & ":"
    c(i, 1) = 0
    For j = 1 To UBound(a)
      If RX.Execute(a(j, 1)).Count = 3 Then c(i, 1) = c(i, 1) + 1
    Next j
  Next i
  Range("O6").Resize(UBound(c)).Value = c
End Sub

Hello Peter_SSs, thank you for the response as the Post#2 macro “Sub Count_Triples()” work fine, I tried to modified to use with quads Post#3 as following

Following line
b = Range("K6", Range("M" & Rows.Count).End(xlUp)).Value
To this one
b = Range("K6", Range("N" & Rows.Count).End(xlUp)).Value


And next line
If RX.Execute(a(j, 1)).Count = 3 Then c(i, 1) = c(i, 1) + 1
To this one
If RX.Execute(a(j, 1)).Count = 4 Then c(i, 1) = c(i, 1) + 1

But getting count result '0' I guess it needs more line to modify. Please help to modify above code to work with Quad, so I can try and I am sure will work better the code post#4.

Best Regards,
Moti

 

[Peter_SSs]

It also requires this modification but I think you will find any improvement is pretty small.

RX.Pattern = ":" & b(i, 1) & ":|:" & b(i, 2) & ":|:" & b(i, 3) & ":"
RX.Pattern = ":" & b(i, 1) & ":|:" & b(i, 2) & ":|:" & b(i, 3) & ":|:" & b(i, 4) & ":"

 

[Phuoc]

Try this code:

Sub Count_lottery()
Dim a As Variant, b As Variant, c As Variant
Dim i&, j&, ra&, rb&, temp$
Dim t As Double
t = Timer
a = Range("D6", Range("H" & Rows.Count).End(xlUp)).Value
b = Range("K6", Range("N" & Rows.Count).End(xlUp)).Value
ra = UBound(a, 1)
rb = UBound(b, 1)
ReDim c(1 To rb, 1 To 2)
For i = 1 To rb
    c(i, 2) = "*" & Format(b(i, 1), "00") & "|*" & Format(b(i, 2), "00") & "|*" & Format(b(i, 3), "00") & "|*" & Format(b(i, 4), "00") & "|*"
Next i
For j = 1 To ra
    temp = Format(a(j, 1), "00|") & Format(a(j, 2), "00|") & Format(a(j, 3), "00|") & Format(a(j, 4), "00|") & Format(a(j, 5), "00|")
    For i = 1 To rb
        If temp Like c(i, 2) Then c(i, 1) = c(i, 1) + 1
    Next i
Next j
Range("P6").Resize(rb, 1) = c
MsgBox Timer - t
End Sub

 

[motilulla]

It also requires this modification but I think you will find any improvement is pretty small.

RX.Pattern = ":" & b(i, 1) & ":|:" & b(i, 2) & ":|:" & b(i, 3) & ":"
RX.Pattern = ":" & b(i, 1) & ":|:" & b(i, 2) & ":|:" & b(i, 3) & ":|:" & b(i, 4) & ":"

Hello Peter_SSs, Thank you, replacing above line with Post#4 macro I tried with my original data as per post#3 layout with 1700+ rows result in column D:H and 65000+ quads in the column K:N, it took 215 second to finish. I tried again Post#4 macro but with this excel do not respond. I appreciate your help. Have a pleasant time. Good Luck.

Best Regards,
Moti