XL 2010 Excel VBA

Konte94 · 21 Février 2020

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 · 21 Février 2020

Bonjour Konte94

Voici un code a adapter en fonction de ton besoin.

VB:

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 · 21 Février 2020

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

VB:

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 :

Code:

=CarréMagique(5)

Konte94 · 21 Février 2020

Fred0o à dit:

Bonjour Konte94

Voici un code a adapter en fonction de ton besoin.

VB:

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 · 21 Février 2020

Re-Bonjour

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

VB:

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 · 21 Février 2020

Konte94 à dit:
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 · 21 Février 2020

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é" :

VB:

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 · 21 Février 2020

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 · 22 Février 2020

Dranreb à dit:

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é" :

VB:

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 · 22 Février 2020

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 · 22 Février 2020

Dranreb à dit:
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 · 22 Février 2020

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 · 22 Février 2020

Dranreb à dit:
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 · 22 Février 2020

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

Konte94 · 22 Février 2020

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

Donc je ne dois pas exécuter ?

XL 2010 Excel VBA

Konte94

XLDnaute Junior

Fred0o

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Konte94

XLDnaute Junior

Fred0o

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Konte94

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

Konte94

XLDnaute Junior

Pièces jointes

Dranreb

XLDnaute Barbatruc

Konte94

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

Konte94

XLDnaute Junior

Discussions similaires