Option Base 1
Option Explicit
Global Big_Array() As String
Dim CurrentRow As Long
Public Sub test()
'auteur: Ger Plante
Dim x As Variant 'this will store each number
Dim y() As String ' this will store the operators
Dim Op_Index1 As Integer 'an index for the operator
Dim Op_Index2 As Integer 'an index for the operator
Dim Op_Index3 As Integer 'an index for the operator
Dim my_formula As String 'a string to construct the formula
Dim Permutations() As String 'an array to store the permutations of the numbers
Dim Base_Numbers As String 'the numbers to check seperated by a comma
Dim iLoop As Integer
Dim iloop2 As Integer
Dim InString As String 'temp string used in creating the permutatons.
ReDim y(4)
y(1) = "+"
y(2) = "-"
y(3) = "*"
y(4) = "/"
'Base_Numbers = "1,2,3,4,5,6"
Base_Numbers = "1,2,3,4"
x = Split(Base_Numbers, ",")
'create all permutations of these numbers (Factorial of the number of numbers)
ReDim Permutations(WorksheetFunction.Fact(UBound(x) + 1))
ReDim Big_Array(WorksheetFunction.Fact(UBound(x) + 1))
For iLoop = LBound(x) To UBound(x)
InString = InString + Chr(48 + iLoop)
Next iLoop
CurrentRow = 1
Call GetPermutation("", InString) 'creates a big array to store permutations
For iLoop = LBound(Big_Array) To UBound(Big_Array)
For iloop2 = 0 To UBound(x)
Permutations(iLoop) = Permutations(iLoop) & x(Mid(Big_Array(iLoop), iloop2 + 1, 1)) & ","
Next iloop2
Permutations(iLoop) = Left(Permutations(iLoop), Len(Permutations(iLoop)) - 1)
Next iLoop
Worksheets(1).Columns("A:B").ClearContents
For iLoop = 1 To UBound(Permutations)
x = Split(Permutations(iLoop), ",")
'if x has four numbers, then there will be three operators to use.
For Op_Index1 = LBound(y) To UBound(y)
For Op_Index2 = LBound(y) To UBound(y)
For Op_Index3 = LBound(y) To UBound(y)
my_formula = x(0) & y(Op_Index1) & x(1) & y(Op_Index2) & x(2) & y(Op_Index3) & x(3)
Worksheets(1).Range("A" & Worksheets(1).Range("A65535").End(xlUp).Row + 1).Value = my_formula & "="
Worksheets(1).Range("B" & Worksheets(1).Range("B65535").End(xlUp).Row + 1).Value = "=" & my_formula
Next Op_Index3
Next Op_Index2
Next Op_Index1
Next iLoop
Worksheets(1).Columns("A:B").AutoFit
End Sub
Sub GetPermutation(x As String, y As String)
' The source of this algorithm is unknown
' copied from ozgrid on 01 June 2006
Dim i As Integer, j As Integer
j = Len(y)
If j < 2 Then
Big_Array(CurrentRow) = x & y
CurrentRow = CurrentRow + 1
Else
For i = 1 To j
Call GetPermutation(x + Mid(y, i, 1), _
Left(y, i - 1) + Right(y, j - i))
Next
End If
End Sub
Sub permut_ii()
Dim chiffres As New Collection
Dim i&, j&, k&, l&, m&, cpt&
cpt = 1
For j = 1 To 9: For k = 1 To 9: For l = 1 To 9: For m = 1 To 9
chiffres.Add j & k & l & m
cpt = cpt + 1
Next: Next: Next: Next
'MsgBox chiffres.Count
'MsgBox chiffres.Item(1)
End Sub
Sub Opérateurs_Staple()
Dim op() As Variant, x1, x2, x3, x4, o1, o2, o3 As Byte
Dim f1, f2, f3, f4, f5 As String
Dim formule As New Collection, combinaison As New Collection
On Error Resume Next 'pour les cas de division par 0
op = Array("+", "-", "*", "/")
For x1 = 1 To 9
For x2 = 1 To 9
For x3 = 1 To 9
For x4 = 1 To 9
For o1 = 0 To 3
For o2 = 0 To 3
For o3 = 0 To 3
f1 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4
f2 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & ")" & op(o3) & x4
f3 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")"
f4 = "(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4
f5 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & op(o3) & x4 & ")"
If IsError(Evaluate(f1)) Then GoTo 1
If Evaluate(f1) = 24 Then formule.Add f1
1 If IsError(Evaluate(f2)) Then GoTo 2
If Evaluate(f2) = 24 Then formule.Add f2
2 If IsError(Evaluate(f3)) Then GoTo 3
If Evaluate(f3) = 24 Then formule.Add f3
3 If IsError(Evaluate(f4)) Then GoTo 4
If Evaluate(f4) = 24 Then formule.Add f4
4 If IsError(Evaluate(f5)) Then GoTo 5
If Evaluate(f5) = 24 Then formule.Add f5
5 Next
Next
Next
Next
Next
Next
Next
MsgBox formule.Count
End Sub
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub Opérateurs_Staple_ii()
Dim lngStart As Long
Dim lngFinish As Long
Dim temps As Long
Dim Hours As Double
Dim Minutes As Double, Seconds As Double
Dim op() As Variant, x1, x2, x3, x4, o1, o2, o3 As Byte
Dim j As Long
Dim f1$, f2$, f3$, f4$, f5$
Dim formule As New Collection, combinaison As New Collection
lngStart = GetTickCount()
On Error Resume Next 'pour les cas de division par 0
op = Array("+", "-", "*", "/")
For x1 = 1 To 9
For x2 = 1 To 9
For x3 = 1 To 9
For x4 = 1 To 9
For o1 = 0 To 3
For o2 = 0 To 3
For o3 = 0 To 3
f1 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4
f2 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & ")" & op(o3) & x4
f3 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")"
f4 = "(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4
f5 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & op(o3) & x4 & ")"
If IsError(Evaluate(f1)) Then GoTo 1
If Evaluate(f1) = 24 Then formule.Add f1
1 If IsError(Evaluate(f2)) Then GoTo 2
If Evaluate(f2) = 24 Then formule.Add f2
2 If IsError(Evaluate(f3)) Then GoTo 3
If Evaluate(f3) = 24 Then formule.Add f3
3 If IsError(Evaluate(f4)) Then GoTo 4
If Evaluate(f4) = 24 Then formule.Add f4
4 If IsError(Evaluate(f5)) Then GoTo 5
If Evaluate(f5) = 24 Then formule.Add f5
5 Next
Next
Next
Next
Next
Next
Next
Application.ScreenUpdating = False
For j = 1 To formule.Count
Cells(j, 1).Formula = "=" & formule.Item(j)
Next
Application.ScreenUpdating = True
lngFinish = GetTickCount()
temps = lngFinish - lngStart ' Get milliseconds
' Convert to Seconds
temps = temps \ 1000
' Pull out HH:MM:SS
Hours = temps \ 3600&
If Hours > 0 Then temps = temps - (3600& * Hours)
Minutes = temps \ 60
Seconds = temps Mod 60
MsgBox Format(CStr(Hours & ":" & Minutes & ":" & Seconds), "hh:mm:ss")
End Sub
Sub Opérateurs_Staple()
Dim op() As Variant, x1, x2, x3, x4, o1, o2, o3 As Byte
Dim f1, f2, f3, f4, f5 As String, cl As Integer
Dim formule As New Collection, combinaison As New Collection
Range("A:A").ClearContents
op = Array("+", "-", "*", "/")
For x1 = 1 To 9
For x2 = 1 To 9
For x3 = 1 To 9
For x4 = 1 To 9
For o1 = 0 To 3
For o2 = 0 To 3
For o3 = 0 To 3
f1 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & x3 & op(o3) & x4
f2 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & ")" & op(o3) & x4
f3 = "(" & x1 & op(o1) & x2 & ")" & op(o2) & "(" & x3 & op(o3) & x4 & ")"
f4 = "(" & x1 & op(o1) & x2 & op(o2) & x3 & ")" & op(o3) & x4
f5 = x1 & op(o1) & "(" & x2 & op(o2) & x3 & op(o3) & x4 & ")"
If IsError(Evaluate(f1)) Then GoTo 1
If Evaluate(f1) = 24 Then
formule.Add f1
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If
1 If IsError(Evaluate(f2)) Then GoTo 2
If Evaluate(f2) = 24 Then
formule.Add f2
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If
2 If IsError(Evaluate(f3)) Then GoTo 3
If Evaluate(f3) = 24 Then
formule.Add f3
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If
3 If IsError(Evaluate(f4)) Then GoTo 4
If Evaluate(f4) = 24 Then
formule.Add f4
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If
4 If IsError(Evaluate(f5)) Then GoTo 5
If Evaluate(f5) = 24 Then
formule.Add f5
cl = classe(x1, x2, x3, x4)
If Application.CountIf(Range("A:A"), cl) = 0 Then
combinaison.Add cl
Range("A" & combinaison.Count) = cl
End If
End If
5 Next
Next
Next
Next
Next
Next
Next
MsgBox "Formules " & formule.Count
MsgBox "Combinaisons " & combinaison.Count
End Sub
Function classe(x1, x2, x3, x4)
y1 = 1 * (x1 & x2 & x3 & x4)
y2 = 1 * (x1 & x2 & x4 & x3)
y3 = 1 * (x1 & x3 & x2 & x4)
y4 = 1 * (x1 & x3 & x4 & x2)
y5 = 1 * (x1 & x4 & x2 & x3)
y6 = 1 * (x1 & x4 & x3 & x2)
y7 = 1 * (x2 & x1 & x3 & x4)
y8 = 1 * (x2 & x1 & x4 & x3)
y9 = 1 * (x2 & x3 & x1 & x4)
y10 = 1 * (x2 & x3 & x4 & x1)
y11 = 1 * (x2 & x4 & x1 & x3)
y12 = 1 * (x2 & x4 & x3 & x1)
y13 = 1 * (x3 & x1 & x2 & x4)
y14 = 1 * (x3 & x1 & x4 & x2)
y15 = 1 * (x3 & x2 & x1 & x4)
y16 = 1 * (x3 & x2 & x4 & x1)
y17 = 1 * (x3 & x4 & x1 & x2)
y18 = 1 * (x3 & x4 & x2 & x1)
y19 = 1 * (x4 & x1 & x2 & x3)
y20 = 1 * (x4 & x1 & x3 & x2)
y21 = 1 * (x4 & x2 & x1 & x3)
y22 = 1 * (x4 & x2 & x3 & x1)
y23 = 1 * (x4 & x3 & x1 & x2)
y24 = 1 * (x4 & x3 & x2 & x1)
classe = Application.Min(y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15, y16, y17, y18, y19, y20, y21, y22, y23, y24)
End Function