XL 2010 Excel VBA

[Konte94]

Salut tout le monde, svp qui peut m'aider à écrire un programme vba qui me permettra d'obtenir un carré magique d'ordre impair avec l'algorithmique de Bachet:

Indication : le nombre 1 doit se placer tout juste en dessous de la cellule centrale.
A chaque fois on descend d'une cellule puis on décale d'une à droite et on met le chiffre consécutif, si on trouve un chiffre là-bas on remonte et on descend de deux cellules et on met le chiffre consécutif ainsi de suite

Exemple
4 9 2
3 5 7
8 1 6

La Somme des lignes, des colonnes et des diagonales est égale.

 

[Fred0o]

Bonjour Konte94

Voici un code a adapter en fonction de ton besoin.

Sub Carre_Magique()
    Cells.Clear
    Taille = 7
    y = Round((Taille + 0.1) / 2, 0) + 1
    x = Round((Taille + 0.1) / 2, 0)
    Cells(y, x) = 1
    For i = 2 To Taille * Taille
        ypre = y
        y = y + 1
        If y > Taille Then y = y - Taille
        xpre = x
        x = x + 1
        If x > Taille Then x = x - Taille
        If Cells(y, x) <> "" Then
            y = ypre + 2
            If y > Taille Then y = y - Taille
            x = xpre
        End If
        Cells(y, x) = i
    Next
End Sub

 

[Dranreb]

Bonjour.
Il semble qu'on puisse faire plus court :

Option Explicit
Function CarréMagique(ByVal Coté As Long) As Variant()
   CalculCarréMagique CarréMagique, Coté
   End Function
Sub CalculCarréMagique(T(), ByVal Coté As Long)
   Dim M As Long, Y As Long, X As Long, L As Long, C As Long, N As Long
   ReDim T(1 To Coté, 1 To Coté)
   M = Coté \ 2
   For Y = -M To M: For X = -M To M
      N = N + 1
      L = X + Y + M + Coté
      C = X - Y + M + Coté
      T(L Mod Coté + 1, C Mod Coté + 1) = N
      Next X, Y
   End Sub

En D2:H6 validé par Ctrl+Maj+Entrée :

=CarréMagique(5)

 

[Konte94]

Bonjour Konte94

Voici un code a adapter en fonction de ton besoin.

Sub Carre_Magique()
    Cells.Clear
    Taille = 7
    y = Round((Taille + 0.1) / 2, 0) + 1
    x = Round((Taille + 0.1) / 2, 0)
    Cells(y, x) = 1
    For i = 2 To Taille * Taille
        ypre = y
        y = y + 1
        If y > Taille Then y = y - Taille
        xpre = x
        x = x + 1
        If x > Taille Then x = x - Taille
        If Cells(y, x) <> "" Then
            y = ypre + 2
            If y > Taille Then y = y - Taille
            x = xpre
        End If
        Cells(y, x) = i
    Next
End Sub

Merci Fred mais est-ce que c'est possible de générer n'importe quel carré magique sans être obligé d'aller changer chaque fois la taille dans le programme

 

[Fred0o]

Re-Bonjour

Bien sur, c'est possible. Voici une des nombreuses solutions envisageables :

Sub Carre_Magique()
    Cells.Clear
    Taille = InputBox("Quelle est la taille du carre ?", "Carre magique") * 1
    y = Round((Taille + 0.1) / 2, 0) + 1
    x = Round((Taille + 0.1) / 2, 0)
    Cells(y, x) = 1
    For i = 2 To Taille * Taille
        ypre = y
        y = y + 1
        If y > Taille Then y = y - Taille
        xpre = x
        x = x + 1
        If x > Taille Then x = x - Taille
        If Cells(y, x) <> "" Then
            y = ypre + 2
            If y > Taille Then y = y - Taille
            x = xpre
        End If
        Cells(y, x) = i
    Next
End Sub

 

[Dranreb]

est-ce que c'est possible de générer n'importe quel carré magique sans être obligé d'aller changer chaque fois la taille dans le programme

Pour mes procédures on leur précise en argument la taille désirée du coté.

 

[Dranreb]

Cette procédure produit la carré magique dans une plage nommée "LeCarréMagique" en prenant comme coté la valeur notée dans une cellule nommée "Coté" :

Sub ProduireCarréMagique()
   Dim Coté As Long, RngCM As Range, T
   On Error Resume Next
   Set RngCM = [LeCarréMagique]: If Err Then MsgBox "Plage nommée ""LeCarréMagique"" introuvable.", vbCritical, "ProduireCarréMagique": Exit Sub
   Coté = ActiveSheet.[Coté].Value: If Err Then MsgBox "Plage nommée ""Coté"" introuvable.", vbCritical, "ProduireCarréMagique": Exit Sub
   RngCM.ClearContents
   Set RngCM = RngCM.Resize(Coté, Coté)
   RngCM.Value = CarréMagique(Coté)
   RngCM.Worksheet.Names.Add "LeCarréMagique", RngCM
   End Sub
Function CarréMagique(ByVal Coté As Long) As Variant()
   CalculCarréMagique CarréMagique, Coté
   End Function
Sub CalculCarréMagique(T(), ByVal Coté As Long)
   Dim M As Long, Y As Long, X As Long, L As Long, C As Long, N As Long
   ReDim T(1 To Coté, 1 To Coté)
   M = Coté \ 2
   For Y = -M To M: For X = -M To M
      N = N + 1
      L = X + Y + M + Coté
      C = X - Y + M + Coté
      T(L Mod Coté + 1, C Mod Coté + 1) = N
      Next X, Y
   End Sub

La référence du nom "LeCarréMagique" est changée à la fin pour pouvoir effacer, la fois d'après, les chiffres en trop si la valeur de Coté est devenue plus petite.

 

[Dranreb]

Information et explication: Je me suis plus basé sur ces illustrations (surtout la première) que sur les descriptions du poste #1 qui m'apparaissaient quelque peu obscures, efffectuant, au moyen d'une multiplication complexe par 1-i une rotation de 45° avec multiplication des distances par racine(2), puis une translation pour que les chiffres des sommets hors cadre viennent réintégrer les case vides du carré au moyen de l'opérateur Mod.

 

[Konte94]

Cette procédure produit la carré magique dans une plage nommée "LeCarréMagique" en prenant comme coté la valeur notée dans une cellule nommée "Coté" :

Sub ProduireCarréMagique()
   Dim Coté As Long, RngCM As Range, T
   On Error Resume Next
   Set RngCM = [LeCarréMagique]: If Err Then MsgBox "Plage nommée ""LeCarréMagique"" introuvable.", vbCritical, "ProduireCarréMagique": Exit Sub
   Coté = ActiveSheet.[Coté].Value: If Err Then MsgBox "Plage nommée ""Coté"" introuvable.", vbCritical, "ProduireCarréMagique": Exit Sub
   RngCM.ClearContents
   Set RngCM = RngCM.Resize(Coté, Coté)
   RngCM.Value = CarréMagique(Coté)
   RngCM.Worksheet.Names.Add "LeCarréMagique", RngCM
   End Sub
Function CarréMagique(ByVal Coté As Long) As Variant()
   CalculCarréMagique CarréMagique, Coté
   End Function
Sub CalculCarréMagique(T(), ByVal Coté As Long)
   Dim M As Long, Y As Long, X As Long, L As Long, C As Long, N As Long
   ReDim T(1 To Coté, 1 To Coté)
   M = Coté \ 2
   For Y = -M To M: For X = -M To M
      N = N + 1
      L = X + Y + M + Coté
      C = X - Y + M + Coté
      T(L Mod Coté + 1, C Mod Coté + 1) = N
      Next X, Y
   End Sub

La référence du nom "LeCarréMagique" est changée à la fin pour pouvoir effacer, la fois d'après, les chiffres en trop si la valeur de Coté est devenue plus petite.

Merci Dranreb pour cette proposition mais j'ai exécuté, sa ne donne rien. Est-ce que vous pouvez m'expliquer comment procéder svp?

 

[Dranreb]

Pouvez vous joindre ce que vous avez essayé ?
Si toutefois vous avez bien créé les noms "Coté" et "LeCarréMagique" dans le classeur ou la feuille.

 

[Konte94]

Pouvez vous joindre ce que vous avez essayé ?
Si toutefois vous avez bien créé les noms "Coté" et "LeCarréMagique" dans le classeur ou la feuille.

Si j'exécute sa fait sa:

 

[Dranreb]

Oui, vous voyez, c'est un message émis par la macro.
Menu Formules, groupe Noms définis, commande Définir un nom.
Définissez aussi le nom "Coté".

 

[Konte94]

Oui, vous voyez, c'est un message émis par la macro.
Menu Formules, groupe Noms définis, commande Définir un nom.
Définissez aussi le nom "Coté".

J'ai pas bien compris. Svp est-ce que vous pouvez me montrer un exemple.

 

[Dranreb]

Qu'est ce que vous n'avez pas compris ?

 

[Konte94]

Qu'est ce que vous n'avez pas compris ?
Regarde la pièce jointe 1055914

Donc je ne dois pas exécuter ?