Search faster using array - But it slows down

  • Thread starter Thread starter Ste Mac
  • Start date Start date
Hi. I may be wrong, but our first difference is as mentioned...

His...
1,2,3,5,8,9

Mine...
1,2,3,5,7,9

I "think" the source of the difference is here.

When we get to 1,2,3,5,7,8
we both agree that this is not valid (ie 1,2,3,7,8 appeared earlier)
and the code sets blNew to False
The code goes on to increment F, and we have...

For F = E + 1 To 30
If Not blNew Then Exit For

We are exiting F here, and not checking 1,2,3,4,7,9

I noticed that in the beginning the code finds the first valid solution.
1,2,3,4,5,6
It then goes on to check
1,2,3,4,5,7

I believe the code was trying / or should, try to exit F here because
there is no need to check F as it goes from 7 to 30. I "Think" this is
the source of our differences.

Again... I may be wrong.

= = = = = = =
Dana DeLouis
 
Oops. Typo again. Sorry.

When we get to 1,2,3,5,7,8
we both agree that this is not valid (ie 1,2,3,7,8 appeared earlier)
and the code sets blNew to False
The code goes on to increment F, and we have...

For F = E + 1 To 30
If Not blNew Then Exit For

We are exiting F here, and not checking 1,2,3,5,7,9

I "Think" this is the source of our differences.


<snip>
 
Hi Dana,

I think you are correct. The optimisation excludes many possible valid sets.

It needs a better approach, any ideas?

regards
Charles
___________________________________
The Excel Calculation Site
http://www.decisionmodels.com
 
Charles said:
Hi Dana,
I think you are correct. The optimisation excludes many possible valid sets.
It needs a better approach, any ideas?

regards
Charles
Click to expand...

<snip>

Hi Charles.
If I am not mistaken, this found 18,655 solutions in 25 Seconds.
= = = = = =
Dana DeLouis

Sub SpecialSubsets()
'// = = = = = = = = = = = = = = = = = = = = = = = = = =
Dim A As Long, B As Long, C As Long, D As Long, E As Long, F As Long
Dim N1 As Long, N2 As Long, N3 As Long, N4 As Long, N5 As Long, N6 As Long
Dim Tme As Double
Dim M 'Matrix
Dim S 'Solutions
Dim T 'Temp Array
'// = = = = = = = = = = = = = = = = = = = = = = = = = =

Set M = CreateObject("Scripting.Dictionary")
Set S = CreateObject("Scripting.Dictionary")

ActiveSheet.Cells.Clear
Tme = Timer
On Error Resume Next
With M

For A = 0 + 1 To 25
For B = A + 1 To 26
For C = B + 1 To 27
For D = C + 1 To 28
For E = D + 1 To 29
For F = E + 1 To 30

N1 = 810000 * A + 27000 * B + 900 * C + 30 * D + E
If .Exists(N1) Then GoTo Skip
N2 = N1 + F - E
If .Exists(N2) Then GoTo Skip
N3 = N2 + 30 * (E - D)
If .Exists(N3) Then GoTo Skip
N4 = N3 + 900 * (D - C)
If .Exists(N4) Then GoTo Skip
N5 = N4 + 27000 * (C - B)
If .Exists(N5) Then GoTo Skip
N6 = N5 + 810000 * (B - A)
If Not .Exists(N6) Then
.Add N1, N1
.Add N2, N2
.Add N3, N3
.Add N4, N4
.Add N5, N5
.Add N6, N6
S.Add S.Count + 1, Array(A, B, C, D, E, F)
Exit For 'Exit remaining F's
End If
Skip:
Next F, E, D, C, B, A
End With
Debug.Print "Timer: ", Timer - Tme
Debug.Print "Size : ", S.Count
Debug.Print "= = = = = = = = = ="
T = S.Items
[A1].Resize(S.Count, 6) = T2(T)
End Sub

Function T2(M)
'// Transpose twice
With WorksheetFunction
T2 = .Transpose(.Transpose(M))
End With
End Function
 
Looks good to me, excellent


Charles
___________________________________
The Excel Calculation Site
http://www.decisionmodels.com

Dana DeLouis said:
Charles said:
Hi Dana,
I think you are correct. The optimisation excludes many possible valid
sets.
It needs a better approach, any ideas?

regards
Charles
Click to expand...

<snip>

Hi Charles.
If I am not mistaken, this found 18,655 solutions in 25 Seconds.
= = = = = =
Dana DeLouis

Sub SpecialSubsets()
'// = = = = = = = = = = = = = = = = = = = = = = = = = =
Dim A As Long, B As Long, C As Long, D As Long, E As Long, F As Long
Dim N1 As Long, N2 As Long, N3 As Long, N4 As Long, N5 As Long, N6 As Long
Dim Tme As Double
Dim M 'Matrix
Dim S 'Solutions
Dim T 'Temp Array
'// = = = = = = = = = = = = = = = = = = = = = = = = = =

Set M = CreateObject("Scripting.Dictionary")
Set S = CreateObject("Scripting.Dictionary")

ActiveSheet.Cells.Clear
Tme = Timer
On Error Resume Next
With M

For A = 0 + 1 To 25
For B = A + 1 To 26
For C = B + 1 To 27
For D = C + 1 To 28
For E = D + 1 To 29
For F = E + 1 To 30

N1 = 810000 * A + 27000 * B + 900 * C + 30 * D + E
If .Exists(N1) Then GoTo Skip
N2 = N1 + F - E
If .Exists(N2) Then GoTo Skip
N3 = N2 + 30 * (E - D)
If .Exists(N3) Then GoTo Skip
N4 = N3 + 900 * (D - C)
If .Exists(N4) Then GoTo Skip
N5 = N4 + 27000 * (C - B)
If .Exists(N5) Then GoTo Skip
N6 = N5 + 810000 * (B - A)
If Not .Exists(N6) Then
.Add N1, N1
.Add N2, N2
.Add N3, N3
.Add N4, N4
.Add N5, N5
.Add N6, N6
S.Add S.Count + 1, Array(A, B, C, D, E, F)
Exit For 'Exit remaining F's
End If
Skip:
Next F, E, D, C, B, A
End With
Debug.Print "Timer: ", Timer - Tme
Debug.Print "Size : ", S.Count
Debug.Print "= = = = = = = = = ="
T = S.Items
[A1].Resize(S.Count, 6) = T2(T)
End Sub

Function T2(M)
'// Transpose twice
With WorksheetFunction
T2 = .Transpose(.Transpose(M))
End With
End Function
Click to expand...
 
Back
Top