BF_LCEB_Source

' ==========================
' BF_LCEB (P)03/2013 MyLzz59
' ==========================

' -----------------
' Zone Déclarations
' -----------------
Dim NbRep, Total As Single, DeltaMax As Single
Dim Plaque(1 To 11) As Single

' -------------------
' Effectuer un Tirage
' -------------------
Sub Tirage()
Randomize Timer
' Construction Chaîne des 24 Plaques
Chaine$ = "": NbPlaq = 24
' ==> de 1 à 10: 2 de chaque
For Vlr = 1 To 10: Chaine$ = Chaine$ + Format$(Vlr, "000") + Format$(Vlr, "000"): Next Vlr
' ==> 25, 50, 75, 100: 1 de chaque
For Vlr = 25 To 100 Step 25: Chaine$ = Chaine$ + Format$(Vlr, "000"): Next Vlr
' Tirer les 6 Plaques de Départ
For Cpt = 1 To 6
    Vlr = 1 + Int(Rnd * NbPlaq) * 3: NbPlaq = NbPlaq - 1
    Plaque(Cpt) = Val(Mid$(Chaine$, Vlr, 3))
    Chaine$ = Left$(Chaine$, Vlr - 1) + Mid$(Chaine$, Vlr + 3)
Next Cpt
' Tirer le Total à Trouver (entre 100 et 999)
Total = 100 + Int(Rnd * 900)
' Ecart Maxi acceptable
DeltaMax = 0 ' <======================================== A Modifier ICI ====================
' .. vers Affiche_Tirage
Affiche_Tirage
' Ligne d'Etat
Application.StatusBar = "Tirage effectué. Bonne chance .."
End Sub

' ------------------------------
' Afficher les Valeurs du Tirage
' ------------------------------
Sub Affiche_Tirage()
' Les 6 Plaques de Départ
For Cpt = 1 To 6: Cells(2, 2 * Cpt + 3).Value = Plaque(Cpt): Next Cpt
' Le Total à Trouver
Cells(2, 21).Value = Total
' Ecart Maxi acceptable
Cells(2, 25).Value = DeltaMax
' .. vers Efface_Reponses
Efface_Reponses
End Sub

' ---------------------------
' Relecture du Tirage Affiché
' ---------------------------
Sub Relecture_Depart()
' Les 6 Plaques de Départ
For Cpt = 1 To 6: Plaque(Cpt) = Cells(2, 2 * Cpt + 3).Value: Next Cpt
' Le Total à Trouver
Total = Cells(2, 21).Value
' Ecart Maxi acceptable
DeltaMax = Cells(2, 25).Value
' .. vers Efface_Reponses
Efface_Reponses
End Sub

' ----------------------------
' Nettoie la Zone des Réponses
' ----------------------------
Sub Efface_Reponses()
' Nettoyage des Lignes des Réponses
NoLig = 5: Do Until Cells(NoLig, 3).Text = "nnn": NoLig = NoLig + 1: Loop
If NoLig > 5 Then Range("5:" + CStr(NoLig - 1)).Delete
' Masquage des Lignes Inutilisées
Range("1:6").EntireRow.Hidden = False
Range("7:" + Mid$(ActiveSheet.Cells.Address, 4)).EntireRow.Hidden = True
' Finaliser
Cells(5, 1).Select: NbRep = 0
End Sub

' -------------------------------
' Ici commence le Calcul Récursif
' -------------------------------
Sub Calcule()
' .. vers Relecture_Depart
Relecture_Depart
' ==> Les 6 Plaques Tirées sont 'nommées' de 'A' à 'F'
' ==> Les 5 Résultats des Etapes sont assimilés à des Plaques 'G' à 'K'
Lst_Plaq$ = "ABCDEF"
K! = Timer: Application.ScreenUpdating = False

' == Etape 0 (s'il fallait trouver la Plaque '100') ==
For Cpt = 1 To 6
    ' -- Retenir ce Résultat ? --
    If Abs(Plaque(Cpt) - Total) <= DeltaMax Then Affiche_Reponse Mid$(Lst_Plaq$, Cpt, 1)
Next Cpt

' == Etape 1 (Procédure Récursive, Etapes 1 à 5) ==
Calcule_Etape Lst_Plaq$, ""
Application.ScreenUpdating = True

' Tri des Résultats
If NbRep Then Rows("5:" + CStr(NbRep + 4)).Sort _
    Key1:=Range("C5"), Order1:=xlAscending, _
    Key2:=Range("B5"), Order2:=xlAscending, _
    Header:=xlNo, OrderCustom:=1

' == Fini ==
Z1$ = "Fini en " + CStr(Timer - K!) + " sec."
Z2$ = CStr(NbRep) + " réponse(s)."
Application.StatusBar = Z1$ + " | " + Z2$
MsgBox Z1$ + vbCrLf + Z2$, vbInformation, Cells(2, 27).Text
End Sub

' -------------------
' Un Niveau de Calcul
' -------------------
Sub Calcule_Etape(ByVal Lst_Plaq$, ByVal Chaine_Src$)
NbPlaq = Len(Lst_Plaq$): NoPlaq = 13 - NbPlaq
' -- Plaque #1 --
For Cpt1 = 1 To NbPlaq
    VPlaq1$ = Mid$(Lst_Plaq$, Cpt1, 1): Lst1$ = Left$(Lst_Plaq$, Cpt1 - 1) + Mid$(Lst_Plaq$, Cpt1 + 1)
    ' -- Plaque #2 --
    For Cpt2 = 1 To NbPlaq - 1
        VPlaq2$ = Mid$(Lst1$, Cpt2, 1): Lst2$ = Left$(Lst1$, Cpt2 - 1) + Mid$(Lst1$, Cpt2 + 1) + Chr$(64 + NoPlaq)
        ' -- Opérateur --
        For Cpt3 = 1 To 4
            Oper$ = Mid$("+-*/", Cpt3, 1)
            ' -- Equation --
            Select Case Oper$
                Case "+"
                    If Cpt2 >= Cpt1 Then
                        Plaque(NoPlaq) = Plaque(Asc(VPlaq1$) - 64) + Plaque(Asc(VPlaq2$) - 64)
                    Else
                        Plaque(NoPlaq) = 0.5 ' Annuler Commutativité de l'Addition
                    End If
                Case "-"
                    Plaque(NoPlaq) = Plaque(Asc(VPlaq1$) - 64) - Plaque(Asc(VPlaq2$) - 64)
                    If Plaque(NoPlaq) < -0.5 Then Plaque(NoPlaq) = 0.5 ' Annuler Résultats Négatifs
                Case "*"
                    If Cpt2 >= Cpt1 Then
                        Plaque(NoPlaq) = Plaque(Asc(VPlaq1$) - 64) * Plaque(Asc(VPlaq2$) - 64)
                    Else
                        Plaque(NoPlaq) = 0.5 ' Annuler Commutativité de la Multiplication
                    End If
                Case "/"
                    If Plaque(Asc(VPlaq2$) - 64) Then
                        Plaque(NoPlaq) = Plaque(Asc(VPlaq1$) - 64) / Plaque(Asc(VPlaq2$) - 64)
                    Else
                        Plaque(NoPlaq) = 0.5 ' Annuler Division par Zéro
                    End If
            End Select
            ' -- Validité de cette Equation --
            If Abs(Plaque(NoPlaq) - Fix(Plaque(NoPlaq))) < 0.0005 Then
                Plaque(NoPlaq) = Fix(Plaque(NoPlaq))
                Chaine_Rest$ = Chaine_Src$ + VPlaq1$ + Oper$ + VPlaq2$ + ";"
                ' -- Retenir cette Equation ? --
                If Abs(Plaque(NoPlaq) - Total) <= DeltaMax Then
                    ' Elimination des Equations Inutilisées
                    Chaine$ = Left$("GHI", NoPlaq - 7): Bool_OK = True
                    For Cpt = 1 To Len(Chaine$)
                        If InStr(Lst2$, Mid$(Chaine$, Cpt, 1)) Then Bool_OK = False
                    Next Cpt
                    If Bool_OK Then Affiche_Reponse Chaine_Rest$
                End If
                ' -- Continuer ? --
                If NoPlaq < 11 Then Calcule_Etape Lst2$, Chaine_Rest$
            End If
        ' -- Fin Opérateur --
        Next Cpt3
    ' -- Fin Plaque #2 --
    Next Cpt2
' -- Fin Plaque #1 --
Next Cpt1
End Sub

' ----------------------------
' Affiche une Ligne de Réponse
' ----------------------------
Sub Affiche_Reponse(ByVal Ch$)
NbRep = NbRep + 1: NoLig = NbRep + 4: Rows(CStr(NoLig) + ":" + CStr(NoLig)).Insert Shift:=xlDown
' Etape 0
Vlr = 0: Cpt = InStr("ABCDEF", Left$(Ch$, 1)): If Cpt Then Vlr = Plaque(Cpt)
' Etapes 1 à 5
NbOper = 0: Cpt = InStr(Ch$, ";")
While Cpt = 4
    NbOper = NbOper + 1: NoCol = 6 * NbOper - 1
    Cpt = InStr("ABCDEFGHIJ", Mid$(Ch$, 1, 1)): If Cpt Then Cells(NoLig, NoCol).Value = Plaque(Cpt)
    Cells(NoLig, NoCol + 1).Value = Mid$(Ch$, 2, 1): Cells(NoLig, NoCol + 3).Value = "="
    Cpt = InStr("ABCDEFGHIJ", Mid$(Ch$, 3, 1)): If Cpt Then Cells(NoLig, NoCol + 2).Value = Plaque(Cpt)
    Vlr = Plaque(NbOper + 6): Cells(NoLig, NoCol + 4).Value = Vlr: Ch$ = Mid$(Ch$, 5): Cpt = InStr(Ch$, ";")
Wend
' Rendu
Cells(NoLig, 2).Value = Vlr: Cells(NoLig, 3).Value = Abs(Vlr - Total)
' Affichage Intermédiaire
If NbRep Mod 10 = 0 Then
    Application.ScreenUpdating = True
    Application.StatusBar = CStr(NbRep) + " Réponses trouvées .."
    DoEvents
    Application.ScreenUpdating = False
End If
End Sub

' ---------
' Interface
' ---------
' ==> Bouton "Tirer"
Private Sub C_Tirage_Click()
Unprotect "": Tirage: Protect ""
End Sub
' ==> Bouton "Chercher"
Private Sub C_Calc_Click()
Unprotect "": Calcule: Protect ""
End Sub

Revenir à l'article principal (BF_LCEB)..

-MyLzz59-