XL 2013 Est t'il possible de réaliser ceci sur excel

Staple1600

XLDnaute Barbatruc
Re

En farfouillant un peu sur la vaste toile, j'ai trouvé cet algorithme (rédigé par Arnaldo Gunzi)
Pour ma part, je me suis contenté de créer le VBA pour la restitution du carré et du coloriage ;)
Par défaut, j'ai mis 4 comme taille
Pour créer un carré de 5x5, mettre 5 dans l'inputBox
etc..
PS: J'ai testé jusqu'à un carré de 50x50
(et Excel n'a pas bronché)
VB:
Sub CréerCarreMagique()
Dim outSquare As Variant, vSize&
vSize = CLng(InputBox("Taille du carré?", "Carré magique en VBA", 4))
Application.ScreenUpdating = False
Cells.Clear
magicsquare vSize, outSquare
Range("B2").Resize(vSize, vSize) = outSquare
[B2].End(xlToRight).Offset(, 1).Resize(vSize) = "=SUM(RC[-" & vSize & "]:RC[-1])"
[B2].End(xlDown).Offset(1).Resize(, vSize) = "=SUM(R[-" & vSize & "]C:R[-1]C)"
With [B2].CurrentRegion
.Borders.LineStyle = 1: .Columns.AutoFit
End With
With [B2].Resize(vSize, vSize)
.Interior.Color = vbBlack: .Font.Color = vbWhite: .Font.Bold = True
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
End With
End Sub
VB:
Private Sub magicsquare(ByVal size As Integer, ByRef Square As Variant)
'May-2010 / Aug 2015 by Arnaldo Gunzi
'Receives the size of the square returns the MagicSquare in outSquare
'algorithms from: mathworld.wolfram.com
Dim i&, j&, posX&, posY&, posXtest&, posYtest&, tam2&, m&
Dim aux() As String
Dim aux2() As Integer
If size < 3 Then
    MsgBox "The square must have size >= 3"
    Exit Sub
End If
ReDim Square(1 To size, 1 To size)
If size Mod 2 = 1 Then
    'For odd size magic Squares
    posX = (size + 1) / 2
    posY = 1
    For i = 1 To size ^ 2
        Square(posY, posX) = i
            If posY = 1 Then
                posYtest = size
            Else
                posYtest = posY - 1
            End If
            If posX = 1 Then
                posXtest = size
            Else
                posXtest = posX - 1
            End If
        If Square(posYtest, posXtest) = 0 Then
            posY = posYtest
            posX = posXtest
        Else
            posY = posY + 1
        End If
    Next i
ElseIf size Mod 4 = 0 Then
    'size 4
    For i = 1 To size
        For j = 1 To size
            If i Mod 4 = 1 Or i Mod 4 = 0 Then
                If j Mod 4 = 0 Or j Mod 4 = 1 Then
                    Square(i, j) = size ^ 2 - (size * (i - 1) + j) + 1
                Else
                    Square(i, j) = size * (i - 1) + j
                End If
            Else
                If j Mod 4 = 2 Or j Mod 4 = 3 Then
                    Square(i, j) = size ^ 2 - (size * (i - 1) + j) + 1
                Else
                    Square(i, j) = size * (i - 1) + j
                End If
            End If
        Next j
    Next i
Else
    'Sie 6,LUX method
     m = (size - 2) / 4
     ReDim aux(1 To 2 * m + 1, 1 To 2 * m + 1)
     ReDim aux2(1 To 2 * m + 1, 1 To 2 * m + 1)

     For i = 1 To m + 1
        For j = 1 To 2 * m + 1
            aux(i, j) = "L"
        Next j
     Next i
    
    For j = 1 To 2 * m + 1
        aux(m + 2, j) = "U"
    Next j
   
     For i = m + 3 To 2 * m + 1
        For j = 1 To 2 * m + 1
            aux(i, j) = "X"
        Next j
     Next i
   
    aux(m + 1, m + 1) = "U"
    aux(m + 2, m + 1) = "L"
   
    tam2 = 2 * m + 1
    posX = (tam2 + 1) / 2
    posY = 1
    For i = 1 To tam2 ^ 2
        aux2(posY, posX) = i
        If aux(posY, posX) = "L" Then
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 2) = 4 * (i - 1) + 1
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 1) = 4 * (i - 1) + 2
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 2) = 4 * (i - 1) + 3
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 1) = 4 * (i - 1) + 4
        ElseIf aux(posY, posX) = "U" Then
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 1) = 4 * (i - 1) + 1
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 1) = 4 * (i - 1) + 2
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 2) = 4 * (i - 1) + 3
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 2) = 4 * (i - 1) + 4
        ElseIf aux(posY, posX) = "X" Then
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 1) = 4 * (i - 1) + 1
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 2) = 4 * (i - 1) + 2
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 1) = 4 * (i - 1) + 3
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 2) = 4 * (i - 1) + 4
        End If
            If posY = 1 Then
                posYtest = tam2
            Else
                posYtest = posY - 1
            End If
            If posX = tam2 Then
                posXtest = 1
            Else
                posXtest = posX + 1
            End If
        If aux2(posYtest, posXtest) = 0 Then
            posY = posYtest
            posX = posXtest
        Else
            posY = posY + 1
        End If
    Next i
End If
End Sub
 
Dernière édition:

Danielle Odette

XLDnaute Occasionnel
Re

En farfouillant un peu sur la vaste toile, j'ai trouvé cet algorithme (rédigé par Arnaldo Gunzi)
Pour ma part, je me suis contenté de créer le VBA pour la restitution du carré et du coloriage ;)
Par défaut, j'ai mis 4 comme taille
Pour créer un carré de 5x5, mettre 5 dans l'inputBox
etc..
PS: J'ai testé jusqu'à un carré de 50x50
(et Excel n'a pas bronché)
VB:
Sub CréerCarreMagique()
Dim outSquare As Variant, vSize&
vSize = CLng(InputBox("Taille du carré?", "Carré magique en VBA", 4))
Application.ScreenUpdating = False
Cells.Clear
magicsquare vSize, outSquare
Range("B2").Resize(vSize, vSize) = outSquare
[B2].End(xlToRight).Offset(, 1).Resize(vSize) = "=SUM(RC[-" & vSize & "]:RC[-1])"
[B2].End(xlDown).Offset(1).Resize(, vSize) = "=SUM(R[-" & vSize & "]C:R[-1]C)"
With [B2].CurrentRegion
.Borders.LineStyle = 1: .Columns.AutoFit
End With
With [B2].Resize(vSize, vSize)
.Interior.Color = vbBlack: .Font.Color = vbWhite: .Font.Bold = True
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
End With
End Sub
VB:
Private Sub magicsquare(ByVal size As Integer, ByRef Square As Variant)
'May-2010 / Aug 2015 by Arnaldo Gunzi
'Receives the size of the square returns the MagicSquare in outSquare
'algorithms from: mathworld.wolfram.com
Dim i&, j&, posX&, posY&, posXtest&, posYtest&, tam2&, m&
Dim aux() As String
Dim aux2() As Integer
If size < 3 Then
    MsgBox "The square must have size >= 3"
    Exit Sub
End If
ReDim Square(1 To size, 1 To size)
If size Mod 2 = 1 Then
    'For odd size magic Squares
    posX = (size + 1) / 2
    posY = 1
    For i = 1 To size ^ 2
        Square(posY, posX) = i
            If posY = 1 Then
                posYtest = size
            Else
                posYtest = posY - 1
            End If
            If posX = 1 Then
                posXtest = size
            Else
                posXtest = posX - 1
            End If
        If Square(posYtest, posXtest) = 0 Then
            posY = posYtest
            posX = posXtest
        Else
            posY = posY + 1
        End If
    Next i
ElseIf size Mod 4 = 0 Then
    'size 4
    For i = 1 To size
        For j = 1 To size
            If i Mod 4 = 1 Or i Mod 4 = 0 Then
                If j Mod 4 = 0 Or j Mod 4 = 1 Then
                    Square(i, j) = size ^ 2 - (size * (i - 1) + j) + 1
                Else
                    Square(i, j) = size * (i - 1) + j
                End If
            Else
                If j Mod 4 = 2 Or j Mod 4 = 3 Then
                    Square(i, j) = size ^ 2 - (size * (i - 1) + j) + 1
                Else
                    Square(i, j) = size * (i - 1) + j
                End If
            End If
        Next j
    Next i
Else
    'Sie 6,LUX method
     m = (size - 2) / 4
     ReDim aux(1 To 2 * m + 1, 1 To 2 * m + 1)
     ReDim aux2(1 To 2 * m + 1, 1 To 2 * m + 1)

     For i = 1 To m + 1
        For j = 1 To 2 * m + 1
            aux(i, j) = "L"
        Next j
     Next i
   
    For j = 1 To 2 * m + 1
        aux(m + 2, j) = "U"
    Next j
  
     For i = m + 3 To 2 * m + 1
        For j = 1 To 2 * m + 1
            aux(i, j) = "X"
        Next j
     Next i
  
    aux(m + 1, m + 1) = "U"
    aux(m + 2, m + 1) = "L"
  
    tam2 = 2 * m + 1
    posX = (tam2 + 1) / 2
    posY = 1
    For i = 1 To tam2 ^ 2
        aux2(posY, posX) = i
        If aux(posY, posX) = "L" Then
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 2) = 4 * (i - 1) + 1
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 1) = 4 * (i - 1) + 2
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 2) = 4 * (i - 1) + 3
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 1) = 4 * (i - 1) + 4
        ElseIf aux(posY, posX) = "U" Then
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 1) = 4 * (i - 1) + 1
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 1) = 4 * (i - 1) + 2
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 2) = 4 * (i - 1) + 3
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 2) = 4 * (i - 1) + 4
        ElseIf aux(posY, posX) = "X" Then
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 1) = 4 * (i - 1) + 1
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 2) = 4 * (i - 1) + 2
            Square(2 * (posY - 1) + 2, 2 * (posX - 1) + 1) = 4 * (i - 1) + 3
            Square(2 * (posY - 1) + 1, 2 * (posX - 1) + 2) = 4 * (i - 1) + 4
        End If
            If posY = 1 Then
                posYtest = tam2
            Else
                posYtest = posY - 1
            End If
            If posX = tam2 Then
                posXtest = 1
            Else
                posXtest = posX + 1
            End If
        If aux2(posYtest, posXtest) = 0 Then
            posY = posYtest
            posX = posXtest
        Else
            posY = posY + 1
        End If
    Next i
End If
End Sub

Bonjour à Tous , Bonjour
Bonsoir le fil,

Peut-être que ceci peut vous intéresser...ou pas
En tout cas, c'est de l'Excel ;)

Bonjour à tout le forum , bonjour Staple1600,

Merci d'avoir répondu à mon post !!!

Je ne sais pas faire , ni ou mettre ce code pourriez vous accepter de le faire

Merci d'avance

Cordialement

Danielle
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil,

Danielle
Ne pas savoir n'est pas un obstacle, mais une invitation...à faire montre de curiosité ;)
En par exemple se rendant sur le 1er moteur de recherche venu
Qui ceci fait, devrait par exemple vous menez ici ;)
Normalement à ce stade, vous devez savoir où doit se mettre le code VBA.

Si ce n'est pas le cas, un dernier indice
Dans Excel, faire ALT+F11
Puis Insertion/Module
Là, dans la carré blanc, copier tout le code VBA de mon précédent message
(donc les deux macros)
Ensuite, appuyez sur la touche F5 puis sélectionner la macro qui s'affiche et cliquez sur Exécuter
Puis de nouveau, sur ALT+F11 pour revenir sur la feuille Excel.

Si tout s'est bien passé, vous devez avoir un carré magique sur la feuille active de votre classeur.
 

Danielle Odette

XLDnaute Occasionnel
Bonsoir le fil,

Danielle
Ne pas savoir n'est pas un obstacle, mais une invitation...à faire montre de curiosité ;)
En par exemple se rendant sur le 1er moteur de recherche venu
Qui ceci fait, devrait par exemple vous menez ici ;)
Normalement à ce stade, vous devez savoir où doit se mettre le code VBA.

Si ce n'est pas le cas, un dernier indice
Dans Excel, faire ALT+F11
Puis Insertion/Module
Là, dans la carré blanc, copier tout le code VBA de mon précédent message
(donc les deux macros)
Ensuite, appuyez sur la touche F5 puis sélectionner la macro qui s'affiche et cliquez sur Exécuter
Puis de nouveau, sur ALT+F11 pour revenir sur la feuille Excel.

Si tout s'est bien passé, vous devez avoir un carré magique sur la feuille active de votre classeur.

Bonsoir le forum ,Staple1600

je viens de suivre vos conseils mais rien se passe pas doué et mon ruban Anglais

dur dur , je suis perdu mais merci de la marche à suivre

En attendant pourriez vous le faire

Cordialement

Danielle

Danielle
 

Staple1600

XLDnaute Barbatruc
Re

J'ai tout décrit dans mon précédent message
Que se passe-t-il quand tu fais ALT+F11
(c'est à dire tout en restant appuyé sur la touche ALT, appuyez simultanément sur la touche F11)


NB: J'ai pris le parti de ne plus joindre de fichier Excel
Ce, entre autre, pour inciter le demandeur à mettre les mains dans le cambouis.
Donc toujours partant pour donner explications, détails et conseils, mais "absent" pour joindre du classeur Excel sur le forum ;)
 

Danielle Odette

XLDnaute Occasionnel
Re

J'ai tout décrit dans mon précédent message
Que se passe-t-il quand tu fais ALT+F11
(c'est à dire tout en restant appuyé sur la touche ALT, appuyez simultanément sur la touche F11)


Il y à un grand carré blanc et plein d'onglets 9 au total ouvert

Ensuite
Re

J'ai tout décrit dans mon précédent message
Que se passe-t-il quand tu fais ALT+F11
(c'est à dire tout en restant appuyé sur la touche ALT, appuyez simultanément sur la touche F11)


NB: J'ai pris le parti de ne plus joindre de fichier Excel
Ce, entre autre, pour inciter le demandeur à mettre les mains dans le cambouis.
Donc toujours partant pour donner explications, détails et conseils, mais "absent" pour joindre du classeur Excel sur le forum ;)

Lorsque j'ai fais cela un grand carré blanc et des onglets se sont ouvert en bas
 

Staple1600

XLDnaute Barbatruc
Re

Donc aprés avoir fait ALT+F11
Tu vas dans le menu Insertion et tu choisis Module
Normalement à cette étape, à gauche tu voir apparaître Module1
Dans la grande zone blanche, à droite de l'écran, tu copies les deux macros du message#2

Est-ce que jusque là, c'est OK ?
 

Danielle Odette

XLDnaute Occasionnel
Re

Donc aprés avoir fait ALT+F11
Tu vas dans le menu Insertion et tu choisis Module
Normalement à cette étape, à gauche tu voir apparaître Module1
Dans la grande zone blanche, à droite de l'écran, tu copies les deux macros du message#2

Est-ce que jusque là, c'est OK ?

J'ai du mal mon ruban anglais , je ne sais pas ou allez
 

Pièces jointes

  • Ruban  anglais.PNG
    Ruban anglais.PNG
    31.4 KB · Affichages: 17

Danielle Odette

XLDnaute Occasionnel
Re

Donc aprés avoir fait ALT+F11
Tu vas dans le menu Insertion et tu choisis Module
Normalement à cette étape, à gauche tu voir apparaître Module1
Dans la grande zone blanche, à droite de l'écran, tu copies les deux macros du message#2

Est-ce que jusque là, c'est OK ?

arrivé à ce stade
 

Pièces jointes

  • ARRIVER A CE STADE.PNG
    ARRIVER A CE STADE.PNG
    28.4 KB · Affichages: 18

Staple1600

XLDnaute Barbatruc
Re

Merci d'être attentive à ce j'écris...
Il y a deux macros à copier
La mienne nommée CréerCarreMagique et celle d'Arnaldo Gunzi
Donc normalement, devrait apparaître CréerCarreMagique dans la boite de dialogue de ta précédente copie d'écran.

PS: Pas de commentaires sur le NB de mon précédent message... :rolleyes: ?
 

Staple1600

XLDnaute Barbatruc
Re

Résumé des étapes (au nombre de trois)
Quand le code VBA est bien collé dans un module et que tu appuies sur F5, voici ci-dessous ce qui doit se passer
guillouche.jpg


1) On choisis la macro et on clique sur Exécuter
2) On laisse 4 ou on saisit un autre nombre (pour définir la taille du carré) et on clique sur OK
3) C'est le résultat qui s'affiche sur l'onglet actif
(ici taille du carré 4, qui est la taille par défaut prévu dans le code VBA)
 

Danielle Odette

XLDnaute Occasionnel
Re

Résumé des étapes (au nombre de trois)
Quand le code VBA est bien collé dans un module et que tu appuies sur F5, voici ci-dessous ce qui doit se passer
Regarde la pièce jointe 1033633

1) On choisis la macro et on clique sur Exécuter
2) On laisse 4 ou on saisit un autre nombre (pour définir la taille du carré) et on clique sur OK
3) C'est le résultat qui s'affiche sur l'onglet actif
(ici taille du carré 4, qui est la taille par défaut prévu dans le code VBA)

Bonjour le Forum et Staple1600,

J'ai réussi pas sans mal en faites je n'avais pas vu que le carré était déjà réalisé

Merci pour ce cours c'est intéressant de faire ,il faut que je change mon excel

pourtant j'ai mis Français mais l'écriture reste Anglais et il faut que je passe la souris dessus

Merci merci

Cordialement

Danielle
 

Discussions similaires