Make a new VBA faster

[motilulla]

Using Excel 2010
Hello,

Here is example with 65 rows in the range B6:O10500 I have a set of combinations and in the range U6:AH4500 I have a set of results. (I want to check all the result against all combinations)

For that I am using formula in cell Q6 below. And the below VBA give me the results in cell R6 Below.

The problem when there is combination with 10500 rows and results with 4500 rows it is taking too much time to populate the results.

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

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

MrExcel.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH
1
2
3
4	10500																			4500
5	Combi	P1	P2	P3	P4	P5	P6	P7	P8	P9	P10	P11	P12	P13	P14		Results Checked With Formula	Results Checked With VBA		Result	P1	P2	P3	P4	P5	P6	P7	P8	P9	P10	P11	P12	P13	P14
6	1	1	1	2	1	1	1	1	1	1	1	1	1	1	1		14	14		1	1	1	2	1	1	1	1	1	1	1	1	1	1	1
7	2	1	1	2	1	1	1	1	1	1	1	1	1	1	X		13	13		2	1	1	2	1	1	1	1	1	1	1	1	1	X	X
8	3	1	1	2	1	1	1	1	1	1	1	1	1	1	2		13	13		3	1	1	2	1	1	1	1	1	1	1	X	1	1	X
9	4	1	1	2	1	1	1	1	1	1	1	1	1	X	1		13	13		4	1	1	2	1	1	1	1	1	1	1	X	1	X	1
10	5	1	1	2	1	1	1	1	1	1	1	1	1	X	X		14	14		5	1	1	2	1	1	1	1	1	1	X	1	1	1	X
11	6	1	1	2	1	1	1	1	1	1	1	1	1	X	2		13	13		6	1	1	2	1	1	1	1	1	1	X	1	1	X	1
12	7	1	1	2	1	1	1	1	1	1	1	X	1	1	1		13	13		7	1	1	2	1	1	1	1	1	1	X	X	1	1	1
13	8	1	1	2	1	1	1	1	1	1	1	X	1	1	X		14	14		8	1	1	2	1	1	1	1	1	1	X	X	1	X	X
14	9	1	1	2	1	1	1	1	1	1	1	X	1	1	2		13	13		9	1	1	2	1	1	1	1	1	1	2	1	1	1	2
15	10	1	1	2	1	1	1	1	1	1	1	X	1	X	1		14	14		10	1	1	2	1	1	1	1	1	1	2	X	1	X	2
16	11	1	1	2	1	1	1	1	1	1	1	X	1	X	X		13	13		11	1	1	2	1	1	1	1	1	X	1	1	1	1	X
17	12	1	1	2	1	1	1	1	1	1	1	X	1	X	2		13	13		12	1	1	2	1	1	1	1	1	X	1	1	1	X	1
18	13	1	1	2	1	1	1	1	1	1	X	1	1	1	1		13	13		13	1	1	2	1	1	1	1	1	X	1	X	1	1	1
19	14	1	1	2	1	1	1	1	1	1	X	1	1	1	X		14	14		14	1	1	2	1	1	1	1	1	X	1	X	1	X	X
20	15	1	1	2	1	1	1	1	1	1	X	1	1	1	2		13	13		15	1	1	2	1	1	1	1	1	X	X	1	1	1	1
21	16	1	1	2	1	1	1	1	1	1	X	1	1	X	1		14	14		16	1	1	2	1	1	1	1	1	X	X	1	1	X	X
22	17	1	1	2	1	1	1	1	1	1	X	1	1	X	X		13	13		17	1	1	2	1	1	1	1	1	X	X	X	1	1	X
23	18	1	1	2	1	1	1	1	1	1	X	1	1	X	2		13	13		18	1	1	2	1	1	1	1	1	X	X	X	1	X	1
24	19	1	1	2	1	1	1	1	1	1	X	X	1	1	1		14	14		19	1	1	2	1	1	1	1	1	X	2	1	1	X	2
25	20	1	1	2	1	1	1	1	1	1	X	X	1	1	X		13	13		20	1	1	2	1	1	1	1	1	X	2	X	1	1	2
26	21	1	1	2	1	1	1	1	1	1	X	X	1	1	2		13	13		21	1	1	2	1	1	1	1	1	2	1	1	1	1	2
27	22	1	1	2	1	1	1	1	1	1	X	X	1	X	1		13	13		22	1	1	2	1	1	1	1	1	2	1	X	1	X	2
28	23	1	1	2	1	1	1	1	1	1	X	X	1	X	X		14	14		23	1	1	2	1	1	1	1	1	2	X	1	1	X	2
29	24	1	1	2	1	1	1	1	1	1	X	X	1	X	2		13	13		24	1	1	2	1	1	1	1	1	2	X	X	1	1	2
30	25	1	1	2	1	1	1	1	1	1	2	1	1	1	1		13	13		25	1	1	2	1	1	1	1	1	2	2	1	1	1	1
31	26	1	1	2	1	1	1	1	1	1	2	1	1	1	X		13	13		26	1	1	2	1	1	1	1	1	2	2	1	1	X	X
32	27	1	1	2	1	1	1	1	1	1	2	1	1	1	2		14	14		27
33	28	1	1	2	1	1	1	1	1	1	2	1	1	X	1		13	13		28
34	29	1	1	2	1	1	1	1	1	1	2	1	1	X	X		13	13		29
35	30	1	1	2	1	1	1	1	1	1	2	1	1	X	2		13	13		30
36	31	1	1	2	1	1	1	1	1	1	2	X	1	1	1		13	13		31
37	32	1	1	2	1	1	1	1	1	1	2	X	1	1	X		13	13		32
38	33	1	1	2	1	1	1	1	1	1	2	X	1	1	2		13	13		33
39	34	1	1	2	1	1	1	1	1	1	2	X	1	X	1		13	13		34
40	35	1	1	2	1	1	1	1	1	1	2	X	1	X	X		13	13		35
41	36	1	1	2	1	1	1	1	1	1	2	X	1	X	2		14	14		36
42	37	1	1	2	1	1	1	1	1	X	1	1	1	1	1		13	13		37
43	38	1	1	2	1	1	1	1	1	X	1	1	1	1	X		14	14		38
44	39	1	1	2	1	1	1	1	1	X	1	1	1	1	2		13	13		39
45	40	1	1	2	1	1	1	1	1	X	1	1	1	X	1		14	14		40
46	41	1	1	2	1	1	1	1	1	X	1	1	1	X	X		13	13		41
47	42	1	1	2	1	1	1	1	1	X	1	1	1	X	2		13	13		42
48	43	1	1	2	1	1	1	1	1	X	1	X	1	1	1		14	14		43
49	44	1	1	2	1	1	1	1	1	X	1	X	1	1	X		13	13		44
50	45	1	1	2	1	1	1	1	1	X	1	X	1	1	2		13	13		45
51	46	1	1	2	1	1	1	1	1	X	1	X	1	X	1		13	13		46
52	47	1	1	2	1	1	1	1	1	X	1	X	1	X	X		14	14		47
53	48	1	1	2	1	1	1	1	1	X	1	X	1	X	2		13	13		48
54	49	1	1	2	1	1	1	1	1	X	X	1	1	1	1		14	14		49
55	50	1	1	2	1	1	1	1	1	X	X	1	1	1	X		13	13		50
56	51	1	1	2	1	1	1	1	1	X	X	1	1	1	2		13	13		51
57	52	1	1	2	1	1	1	1	1	X	X	1	1	X	1		13	13		52
58	53	1	1	2	1	1	1	1	1	X	X	1	1	X	X		14	14		53
59	54	1	1	2	1	1	1	1	1	X	X	1	1	X	2		13	13		54
60	55	1	1	2	1	1	1	1	1	X	X	X	1	1	1		13	13		55
61	56	1	1	2	1	1	1	1	1	X	X	X	1	1	X		14	14		56
62	57	1	1	2	1	1	1	1	1	X	X	X	1	1	2		13	13		57
63	58	1	1	2	1	1	1	1	1	X	X	X	1	X	1		14	14		58
64	59	1	1	2	1	1	1	1	1	X	X	X	1	X	X		13	13		59
65	60	1	1	2	1	1	1	1	1	X	X	X	1	X	2		13	13		60
Check Results

Cell Formulas
Range	Formula
Q6:Q65	Q6	=MAX(MMULT(--($U$6:$AH$20000=B6:O6),TRANSPOSE(COLUMN($U$6:$AH$6))^0))
Press CTRL+SHIFT+ENTER to enter array formulas.

Sub Formula_InTo_VBA()
Dim a, b, c
Dim i As Long, j As Long, k As Long, n As Long

Range("R6:R20000").ClearContents

Application.ScreenUpdating = False

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

For i = 1 To UBound(a, 1)
    xmax = 0
    For j = 1 To UBound(b, 1)
        n = 0
        For k = 1 To 14
            If a(i, k) = b(j, k) Then n = n + 1
        Next k
        xmax = Application.Max(xmax, n)
        Next j
  
    c(i) = xmax
Next i

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

Application.ScreenUpdating = True

End Sub

Regards,
Moti

 

[rlv01]

Replace Application.Max(xmax, n), e.g.

            'xmax = Application.Max(xmax, n)
            If n > xmax Then
                xmax = n
            End If

 

[motilulla]

Replace Application.Max(xmax, n), e.g.

            'xmax = Application.Max(xmax, n)
            If n > xmax Then
                xmax = n
            End If

Hello rlv01, your 3 line code has reduced significant time from previous 00:04:21Minutes, to 00:01:13 Minutes. Great efforts I appreciate your help.

I will wait if it could be reduced more from the 00:01:13 Minutes to less time.

Kind Regards,
Moti

 

[rlv01]

I think you have seen most of the speed improvement you are going to see with your code in it's current form.
You have written your code using 3 nested loops.

    For i = 1 To UBound(a, 1)
        For j = 1 To UBound(b, 1)
            For k = 1 To 14
                
            Next k
        Next j
    Next i

That's better than 50 million iterations of the inner loop for a 2000 row worksheet. Any further improvement would need a fundamental re-write that abandons the nested loops in favor of some other approach to get what you want.

 

[motilulla]

I think you have seen most of the speed improvement you are going to see with your code in it's current form.
You have written your code using 3 nested loops.

    For i = 1 To UBound(a, 1)
        For j = 1 To UBound(b, 1)
            For k = 1 To 14
               
            Next k
        Next j
    Next i

That's better than 50 million iterations of the inner loop for a 2000 row worksheet. Any further improvement would need a fundamental re-write that abandons the nested loops in favor of some other approach to get what you want.

Hello rlv01, thank you for your reply. I do not have much idea of coding and I will be grateful of you if you can please re-write the new VBA to get results in less time.

Kind Regards,
Moti

 

[rlv01]

Hello rlv01, thank you for your reply. I do not have much idea of coding and I will be grateful of you if you can please re-write the new VBA to get results in less time.

Kind Regards,
Moti

I'm sorry, but I am not able to take on this job of work for you.

 

[motilulla]

I'm sorry, but I am not able to take on this job of work for you.

rlv01, no problem, thank you for your reply. I am already gratefully to you for your help reducing significant time.

I will wait May someone could help to rewrite and make it faster.

Good luck!

Kind Regards,
Moti

 

[motilulla]

Please need help rewrite VBA, to get faster results.

 

[motilulla]

Please any chance to make this result checker faster?

 

[Fluff]

You should know better than this.
Please provide the link to all & any crossposts.