Autres Petits challenges VBA

[Cousinhub]

Bonsoir,
Un petit challenge, pour les VBAïstes endurcis
Sans boucle, remplir de A1 à A12, les mois de l'année
PS, si vous avez la solution, ne pas la mettre de suite, mais juste signaler (et me l'envoyer en MP)
Bonne soirée
Edit : Solution applicable toutes versions 🙂

 

[Cousinhub]

Hi,
Comme il y a eu plus d'un challenge, j'ai modifié le titre...
Bonne surchauffe à tous

 

[patricktoulon]

re allez j'y vais de ma salade moi aussi
bon elle est gentille pas trop mechante

Function tourne_la_roue_et_tourne_tourne_et_tourne() As Object
    Dim bidule As Object, pi As Double, DivI As Long, TourneAutour As Double, Pied As Double, HolAA As Double
    Dim baton As Double, index As Long, coin As Double
    
    
    Set bidule = CreateObject("Scripting.Dictionary")
    pi = Atn(1) * 4
    DivI = CLng("&HC")
    TourneAutour = 2 * pi
    Pied = pi / 180
    HolAA = 0.00001
    baton = 1
    coin = 0
    Do While coin < TourneAutour
        If Abs((coin * DivI / TourneAutour) - Round(coin * DivI / TourneAutour)) < HolAA Then
            Dim i As Long
            i = Round(coin * DivI / TourneAutour)
            Dim x As Double, y As Double
            x = Cos(coin) * baton
            y = Sin(coin) * baton
            If i > 0 Then bidule.Add MonthName(i), Array("reperes(" & i & ")", x, y)
        End If
        coin = coin + Pied
    Loop
    Set tourne_la_roue_et_tourne_tourne_et_tourne = bidule
End Function

Sub TestCerclesMystiques()
    Dim r As Object, ks, k
    Set r = tourne_la_roue_et_tourne_tourne_et_tourne()
    ks = r.keys
    'lecture array keys
    [A1:A12] = Application.Transpose(ks)
    'lecture profonde
    'For Each k In r
    'Debug.Print k, "x=" & Format(r(k)(0), "0.000"), "y=" & Format(r(k)(1), "0.000")
    'Next
End Sub

 

[Nicolas JACQUIN]

Bonjour à tous,

Tant qu'à être dans l'extrême,

Sub La_Litanie_Hyperbaroque_des_Douze_Gardiennes_du_Temps()
    Dim codexDesGardiennes As Object
    Set codexDesGardiennes = CreateObject("Scripting.Dictionary")

    Dim piDesAnciens As Double
    piDesAnciens = 4 * Atn(1)
    
    Dim cercleSacré As Double
    cercleSacré = piDesAnciens * 2

    Dim fragmentsAngulaires As Double
    fragmentsAngulaires = piDesAnciens / 180

    Dim seuilDExistence As Double
    seuilDExistence = Exp(Log(0.00001))

    Dim étalonDeLigne As Double
    étalonDeLigne = Sqr(1)

    Dim ondeChronoAngulaire As Double
    ondeChronoAngulaire = 0

    Dim nombreDesMasques As Long
    nombreDesMasques = &HC

    Do While ondeChronoAngulaire < cercleSacré And codexDesGardiennes.Count < 12
        Dim ratioDeRésonance As Double
        ratioDeRésonance = (ondeChronoAngulaire * nombreDesMasques) / cercleSacré
        
        If Abs(ratioDeRésonance - Round(ratioDeRésonance)) < seuilDExistence Then
            Dim identifiantDuSceau As Long
            identifiantDuSceau = Round(ratioDeRésonance)
            
            If identifiantDuSceau >= 1 And identifiantDuSceau <= 12 Then
                Dim nomMystique As String
                nomMystique = MonthName(identifiantDuSceau)
                
                If Not codexDesGardiennes.Exists(nomMystique) Then
                    Dim coordonnéesDuPortail(1 To 3) As Variant
                    coordonnéesDuPortail(1) = "glyph_" & identifiantDuSceau
                    coordonnéesDuPortail(2) = Cos(ondeChronoAngulaire) * étalonDeLigne
                    coordonnéesDuPortail(3) = Sin(ondeChronoAngulaire) * étalonDeLigne
                    codexDesGardiennes.Add nomMystique, coordonnéesDuPortail
                End If
            End If
        End If
        ondeChronoAngulaire = ondeChronoAngulaire + fragmentsAngulaires
    Loop

    Dim indexDimensionnel As Long: indexDimensionnel = 1
    Dim entité As Variant
    
    For Each entité In codexDesGardiennes.Keys
        With Cells(indexDimensionnel, 1)
            .Value = entité
            .Font.Bold = True
            .Font.Name = "Papyrus"
            .Font.Size = 14
            .Interior.Color = RGB(255 - indexDimensionnel * 10, 200, 150 + indexDimensionnel * 8)
        End With
        indexDimensionnel = indexDimensionnel + 1
    Next entité

    MsgBox "Les Douze Gardiennes sont descendues du cercle. Leurs noms résonnent de A1 à A12.", vbOKOnly + vbInformation, "Rituel accompli"
End Sub

A bientôt.
Nicolas

 

[Nicolas JACQUIN]

Re,
J'avais celle-ci, encore un peu plus tordue :

Option Explicit

Sub Le_Grand_Rite_Final_De_L_HyperRoue_MetaChronoSpatiale()
    Dim transducteurChrono As Object
    Set transducteurChrono = invoquer_l_oracle_des_mois()

    Dim clefDuDestin As Variant
    Dim ligneDuGrimoire As Long: ligneDuGrimoire = 1

    For Each clefDuDestin In transducteurChrono.Keys
        Call graverLeNomSacréDansLaPierre(CStr(clefDuDestin), ligneDuGrimoire)
        ligneDuGrimoire = ligneDuGrimoire + 1
    Next

    Call déclamerLaProphétie
End Sub

Function invoquer_l_oracle_des_mois() As Object
    Dim fluxDesMois As Object
    Set fluxDesMois = CreateObject("Scripting.Dictionary")
   
    Dim axeTemporel As Double: axeTemporel = initPi() * 2
    Dim seuilInvisibilité As Double: seuilInvisibilité = invocationDuSeuil(0.00001)
    Dim angle As Double: angle = 0
    Dim pas As Double: pas = axeTemporel / 360
    Dim nombrePortails As Long: nombrePortails = &HC

    Do While angle < axeTemporel And fluxDesMois.Count < 12
        Dim échoTemporel As Double
        échoTemporel = (angle * nombrePortails) / axeTemporel

        If différenceQuantique(échoTemporel, Round(échoTemporel)) < seuilInvisibilité Then
            Dim moisIndex As Long
            moisIndex = Round(échoTemporel)
            If moisIndex >= 1 And moisIndex <= 12 Then
                Dim nom As String
                nom = interrogerLeSpiraleurDeNoms(moisIndex)
                If Not fluxDesMois.Exists(nom) Then
                    fluxDesMois.Add nom, Array(angle, Cos(angle), Sin(angle))
                End If
            End If
        End If
        angle = angle + pas
    Loop

    Set invoquer_l_oracle_des_mois = fluxDesMois
End Function

Function initPi() As Double
    initPi = 4 * Atn(1) ' l’antique savoir
End Function

Function invocationDuSeuil(valeur As Double) As Double
    invocationDuSeuil = Exp(Log(valeur)) ' purement théâtral
End Function

Function différenceQuantique(a As Double, b As Double) As Double
    différenceQuantique = Abs(a - b)
End Function

Function interrogerLeSpiraleurDeNoms(index As Long) As String
    If index < 1 Or index > 12 Then interrogerLeSpiraleurDeNoms = "???": Exit Function
    interrogerLeSpiraleurDeNoms = MonthName(index)
End Function

Sub graverLeNomSacréDansLaPierre(nom As String, ligne As Long)
    With Cells(ligne, 1)
        .Value = nom
        .Font.Name = "Garamond"
        .Font.Size = 16 + (ligne Mod 3)
        .Font.Bold = True
        .Font.Color = RGB(100 + ligne * 10, 0, 255 - ligne * 15)
        .Interior.Color = RGB(255 - ligne * 10, 255, 200 + ligne * 3)
    End With
End Sub

Sub déclamerLaProphétie()
    Dim paroles As Variant
    paroles = Array( _
        "Ils sont douze, et veillent sur la roue...", _
        "Chaque nom est une clef, chaque clef un passage.", _
        "Le temps est un cercle, et le cercle est complet.", _
        "Regarde les mois. Mais ne les nomme pas à la légère." _
    )
   
    Dim i As Long
    For i = LBound(paroles) To UBound(paroles)
        Application.StatusBar = paroles(i)
        Application.Wait Now + TimeValue("00:00:01")
    Next i
    Application.StatusBar = False
    MsgBox "La Roue tourne. Les Noms sont en place.", vbOKOnly + vbExclamation, "Rite Complété"
End Sub

Nicolas