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

 

[motilulla]

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

Hello Fluff, I am sorry, sure here is below the link to cross post.
Please need help to rewrite the VBA

Please anyone can download the file from link above to make a VBA result faster.

Here rlv01, has helped in the post#2 after replacing those lines VBA has reduced significant time but according to rlv01 it need to rewrite for further improvement. Please Help

Regards,
Moti

 

[motilulla]

Please Help

 

[Alex Blakenburg]

See if this helps:
(It is based on your file which has the results column starting at S and not T)

Sub Formula_InTo_VBA()
    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
   
    Range("Q6:Q20000").ClearContents
   
    Application.ScreenUpdating = False
   
    Lr = Cells(Rows.Count, "B").End(xlUp).Row
    a = Range("B6:O" & Lr)
    ReDim c(1 To Lr, 1 To 1)
    Lr = Cells(Rows.Count, "U").End(xlUp).Row
    'b = Range("U6:AH" & Lr)
    b = Range("T6:AG" & Lr)
   
    iPossible = UBound(b)
   
    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 14
                If a(i, k) = b(j, k) Then
                    n = n + 1
                Else
                    ' if more misses than the best so fart 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("Q6").Resize(UBound(c, 1), 1) = c
   
    Application.ScreenUpdating = True
   
    Debug.Print Timer - startTime
     
End Sub

 

[motilulla]

See if this helps:
(It is based on your file which has the results column starting at S and not T)

Hello Alex Blakenburg, It is true results starting from the columns S good catch.

I tried your code with attached file I noticed that it works smooth without making a noise but the result timings are same (with your and attached macro) 00:01:14 Minute. I think you would have tested also.

With attached macro machine were making too noise and I was getting massage excel (No Responding) some time it was getting block too.

I am grateful to you for re-writing a code and it is performing great.

Have a good weekend and Good Luck.

My Best regards,
Moti

 

[Alex Blakenburg]

Appreciate the feedback. Glad we were able to help.

 

[Alex Blakenburg]

Hi Moti @motilulla

I spotted an issue with the code I gave you. Please change this line.
and see if it makes a difference.

iPossible = UBound(b)
' it should be
iPossible = UBound(b, 2)

Also I revisited an earlier attempt using an dictionary and by combining it with the code I posted I believe it faster than the previous version.

Sub Formula_InTo_VBA_Escapev_RngAdj_AddDict()
    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
    Dim dicResult As Object, dicKey As String
    
    Range("Q6:Q20000").ClearContents
    
    Application.ScreenUpdating = False
    
    Lr = Cells(Rows.Count, "B").End(xlUp).Row
    a = Range("B6:O" & Lr)
    ReDim c(1 To Lr, 1 To 1)
    Lr = Cells(Rows.Count, "T").End(xlUp).Row 
    b = Range("T6:AG" & Lr)
    
    iPossible = UBound(b, 2)
    
    Set dicResult = CreateObject("Scripting.dictionary")
    dicResult.CompareMode = vbTextCompare
    For i = 1 To UBound(b, 1)
        dicKey = ""
        For j = 1 To UBound(b, 2)
            dicKey = dicKey & "|" & b(i, j)
        Next j
        dicKey = Right(dicKey, Len(dicKey) - 1)
        If Not dicResult.exists(dicKey) Then
            dicResult(dicKey) = i
        End If
    
    Next i

    For i = 1 To UBound(a, 1)
        xmax = 0
        xMiss = iPossible
        
        dicKey = ""
        For m = 1 To UBound(a, 2)
            dicKey = dicKey & "|" & a(i, m)
        Next m
        dicKey = Right(dicKey, Len(dicKey) - 1)
        If Not dicResult.exists(dicKey) Then
          
          For j = 1 To UBound(b, 1)
              n = 0
              iMiss = 0
              For k = 1 To 14
                  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
              ' Shouldn't need this the dictionary lookup so catch it before here
              If xmax = iPossible Then Exit For
          Next j
        Else
            xmax = iPossible
        End If
          c(i, 1) = xmax
    Next i
    
    Range("Q6").Resize(UBound(c, 1), 1) = c
    
    Application.ScreenUpdating = True
    
    Debug.Print Timer - startTime
End Sub

 

[motilulla]

Hi Moti @motilulla

I spotted an issue with the code I gave you. Please change this line.
and see if it makes a difference.

iPossible = UBound(b)
' it should be
iPossible = UBound(b, 2)

Also I revisited an earlier attempt using an dictionary and by combining it with the code I posted I believe it faster than the previous version.

Sub Formula_InTo_VBA_Escapev_RngAdj_AddDict()
    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
    Dim dicResult As Object, dicKey As String
   
    Range("Q6:Q20000").ClearContents
   
    Application.ScreenUpdating = False
   
    Lr = Cells(Rows.Count, "B").End(xlUp).Row
    a = Range("B6:O" & Lr)
    ReDim c(1 To Lr, 1 To 1)
    Lr = Cells(Rows.Count, "T").End(xlUp).Row
    b = Range("T6:AG" & Lr)
   
    iPossible = UBound(b, 2)
   
    Set dicResult = CreateObject("Scripting.dictionary")
    dicResult.CompareMode = vbTextCompare
    For i = 1 To UBound(b, 1)
        dicKey = ""
        For j = 1 To UBound(b, 2)
            dicKey = dicKey & "|" & b(i, j)
        Next j
        dicKey = Right(dicKey, Len(dicKey) - 1)
        If Not dicResult.exists(dicKey) Then
            dicResult(dicKey) = i
        End If
   
    Next i

    For i = 1 To UBound(a, 1)
        xmax = 0
        xMiss = iPossible
       
        dicKey = ""
        For m = 1 To UBound(a, 2)
            dicKey = dicKey & "|" & a(i, m)
        Next m
        dicKey = Right(dicKey, Len(dicKey) - 1)
        If Not dicResult.exists(dicKey) Then
         
          For j = 1 To UBound(b, 1)
              n = 0
              iMiss = 0
              For k = 1 To 14
                  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
              ' Shouldn't need this the dictionary lookup so catch it before here
              If xmax = iPossible Then Exit For
          Next j
        Else
            xmax = iPossible
        End If
          c(i, 1) = xmax
    Next i
   
    Range("Q6").Resize(UBound(c, 1), 1) = c
   
    Application.ScreenUpdating = True
   
    Debug.Print Timer - startTime
End Sub

Wow Alex Blakenburg, I am speechless by this update this has reduced time by previous code 00:00:98 Minutes nearly 1 Minute. Previous code were finished in 00:01:28 Minutes and this one in 00:00:20 Minutes.

I am so happy I can’t express you and grateful to you for giving me an excellent time saver solution. It is performing like magic.

I have change and marked this as better ever solution.

Good night, have a safe weekend. And Good Luck! to you forever.

My Best regards,
Moti

 

[Alex Blakenburg]

Thanks Moti. You've made my day.