Défi VBA (cubes)

[police]Défi VBA (cubes)[/police]

Que ce soit pour le plaisir de relever ce défi ou simplement pour vous entraîner, je vous propose un petit exercice pas trop long à réaliser et plutôt sympathique

Pour rendre l'exercice plus intéressant, les résultats des autres participants ne seront pas publiés tout de suite pour éviter que vous ne soyez tenté de vous en inspirer (malgré vous) et vous forcer à rechercher des solutions par vous-même.

Et quelques jours plus tard, à la publication, on devrait avoir à disposition des résultats assez variés et vous y découvrirez probablement des solutions auxquelles vous n'aviez pas pensé.

Je pense que ça peut être très intéressant comme exercice, ce "défi n°1" est un test (si c'est quelque chose qui vous plaît, il y en aura peut-être d'autres).


[police]L'exercice[/police]

Une cellule contient des données représentant un ou plusieurs blocs aux dimensions variables (les blocs sont séparés par des / ).

Par exemple, si la cellule contient 6x6x3/3x3x3, cela correspond à 2 blocs :

  • Dimensions du bloc 1 : 6x6x3
  • Dimensions du bloc 2 : 3x3x3

LE PROBLEME :

Imaginez que vous deviez découper tous ces blocs en cubes de taille identique, en faire les plus gros cubes possible et sans aucun reste, combien de cubes obtenez-vous ?

PAR EXEMPLE :

Avec un bloc de 6x6x3 et un autre de 3x3x3, pour ne laisser aucun reste, il serait possible de découper des cubes de 1x1x1 ou 3x3x3 (nombres entiers uniquement). Ici, on recherche à faire les plus gros cubes, c'est donc 3x3x3 qui est retenu.

Dans le bloc de 6x6x3, on peut découper 4 cubes de 3x3x3 et dans le second bloc de 3x3x3, 1 cube.

Au total, cela fait 5 cubes de taille identique, les plus grands possible et sans reste.

Donc si la cellule contient 6x6x3/3x3x3, la macro devra renvoyer le résultat 5.

L'EXERCICE :

Complétez la macro suivante dans le fichier fourni :

Private Sub CommandButton_defi_Click()

    'Votre code ici

End Sub

Au clic sur le bouton "Lancer la macro", cette macro devra compléter les cellules en vert (en entrant dans chaque cellule le nombre de cubes en fonction des blocs de la colonne A) :

defi 1

Les résultats attendus sont entrés dans la colonne B (cela vous permettra de vérifier si vos résultats sont corrects).

Si possible, commentez votre macro pour en faciliter la compréhension pour les autres membres !

Le fichier à télécharger (en version xls ou xlsm) :

209defi-1.xlsm (22.30 Ko)
233defi-1.zip (15.37 Ko)

PARTAGEZ VOTRE MACRO :

Si vous trouvez une solution fonctionnelle, vous pouvez poster votre macro "CommandButton_defi_Click" à la suite de ce post.

FACULTATIF :

Si vous souhaitez aller plus loin dans le défi, essayez de créer la macro la plus courte possible pour réaliser ce même travail et ajoutez également cette seconde macro dans le même post.

Bonjour à tous,

Voici une solution :

Private Sub CommandButton_defi_Click()

    'Votre code ici
    'explication de l'algorithme :
    '1- on calcule le nombre d'éléments total que contiennent les blocs
    '   ex pour les blocs 8x2x2/2x1x1 : 8*2*2 + 2*1*1 = 34
    '2- on calcule ensuite le plus grand dénominateur commun (PGCD) à toutes les "dimensions" des blocs
    '   dans notre exemple, on cherche le PGCD de 8, 2 et 1 qui sera donc 1
    '3- on utilisera donc 34/(1*1*1)=34 cubes de dimension 1 (1x1x1)

    'explication du code utilisé :
    '1- on remplace les "/" par des "+" et les "x" par des "*" pour obtenir 8*2*2+2*1*1
    '   on utilise ensuite la fonction VBA Evaluate afin d'évaluer le calcul obtenu (ne pas oublier d'ajouter un "=" devant)
    '2- on utilise la fonction Split afin de récupérer toutes les "dimensions" des blocs
    '   ces dimensions sont automatiquement transférées dans une variable tableau sur laquelle on utilisera la fonction GCD (Great Common Divisor)
    '3- il ne reste plus qu'à faire le quotient des valeurs trouvées en 1 et 2

    For i = 2 To 8    'boucle sur chaque valeur
        Cells(i, 3) = Evaluate("=" & Replace(Replace(Cells(i, 1), "/", "+"), "x", "*")) / Application.Gcd(Split(Replace(Cells(i, 1), "x", "/"), "/")) ^ 3
    Next i

End Sub

Bien sûr, on peut mettre la boucle sur 1 ligne en utilisant les ":" mais ça revient au même...

Salut Sébastien

Option Explicit

Private Sub CommandButton_defi_Click()
'Défi VBA n°1 (cubes)
'Par Mytå, le 28 avril 2013

Dim Bloc() As String, Blocs() As String, Cubes() As Integer
Dim Cel As Range, Expr As String
Dim i As Byte, PGD As Byte, Rep As Long

    For Each Cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        ReDim Cubes(0)
        Bloc = Split(Cel, "/")

        For i = 0 To UBound(Bloc)
            Blocs = Split(Bloc(i), "x")
            ReDim Preserve Cubes(UBound(Cubes) + 3)
            Cubes(UBound(Cubes) - 2) = Blocs(0)
            Cubes(UBound(Cubes) - 1) = Blocs(1)
            Cubes(UBound(Cubes)) = Blocs(2)
        Next i

        Expr = ""
        For i = 1 To UBound(Cubes)
            Expr = Expr & Cubes(i) & ","
        Next i

        PGD = Evaluate("=GCD(" & Expr & ")")
        Rep = 0
        For i = 1 To UBound(Cubes) Step 3
            Rep = Rep + Cubes(i) / PGD * Cubes(i + 1) / PGD * Cubes(i + 2) / PGD
        Next i
        Cel.Offset(, 2) = Rep
    Next Cel

End Sub

Petite précision sur mon code, il faut remplacer selon les versions d'Excel

        PGD = Evaluate("=PGCD(" & Expr & ")")  'Excel 2003
         PGD = Evaluate("=GCD(" & Expr & ")")    'Excel 2007/2010

J'avais bâti mon code sous Excel 2003, sans tester avec les autres versions.

Mytå

Salut Sébastien, Bonjour le Forum,

Voici ma solution.

Option Explicit
Private Sub CommandButton_defi_Click()
Dim i As Integer, j As Integer, k As Integer, m As Integer, n As Integer, p As Integer, q As Long
Dim PPCD As Integer

Application.ScreenUpdating = False

For i = 2 To 8
    Range("A10") = Range("A" & i)
Retour:
    On Error Resume Next
    j = Application.WorksheetFunction.Find("/", Range("A10"))
    k = Application.WorksheetFunction.Find("x", Range("A10"))

    If j = 0 And k = 0 Then
        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = Range("A10")
        Range("A10") = ""
        GoTo Etiquette
    End If

    If j = 0 Or k = 0 Then
        n = Application.WorksheetFunction.Max(j, k)
    Else
        n = Application.WorksheetFunction.Min(j, k)
    End If

    Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = Left(Range("A10"), n - 1)
    Range("A10") = Right(Range("A10"), Len(Range("A10")) - n)

    j = 0
    k = 0
    GoTo Retour

Etiquette:

PPCD = Application.WorksheetFunction.Gcd(Range("A11:A" & Range("A" & Rows.Count).End(xlUp).Row))

    For p = 11 To Range("A" & Rows.Count).End(xlUp).Row Step 3
        q = q + ((Cells(p, 1) / PPCD) * (Cells(p + 1, 1) / PPCD) * (Cells(p + 2, 1) / PPCD))
    Next p

    Cells(i, 3) = q

    Range("A10:A" & Rows.Count).ClearContents
    q = 0

Next i

End Sub

Cordialement.

128defi-1-yvouille.zip (17.23 Ko)
Option Explicit
Private Sub CommandButton_defi_Click()
' Je nomme arête l'une des 3 dimensions d'un bloc
Dim Str_Blocs As String, Bloc As String, p As Byte, i As Byte, j As Byte, N As Long, Ligne As Byte
Dim Nb_Arêtes As Integer, Pgcd As Integer, Nb_Cubes As Long
Dim T_Arêtes() As Integer ' Tableau des longueurs (sous forme nombre entier) des arêtes de chaque bloc

' On nomme les 3 colonnes de la plage par leur entête
Range("A1").CurrentRegion.CreateNames Top:=True, Left:=False

For Ligne = 1 To Range("Blocs").Cells.Count
    Str_Blocs = Range("Blocs").Cells(Ligne).Value & "/"

    ReDim T_Arêtes(Nb_Blocs(Str_Blocs) * 3)
    ' Recherche du nombre total d'arêtes pour tous les blocs et mise en tableau des valeurs de ces arêtes
    p = 0: Nb_Arêtes = 0
    For i = 1 To Len(Str_Blocs)
        If Mid(Str_Blocs, i, 1) = "x" Or Mid(Str_Blocs, i, 1) = "/" Then
            T_Arêtes(Nb_Arêtes) = Val(Mid(Str_Blocs, p + 1, i - p - 1))
            Nb_Arêtes = Nb_Arêtes + 1
            p = i
        End If
    Next

    ' Recherche du PGCD de toutes les arêtes pour l'ensemble des blocs
    Pgcd = Application.Gcd(T_Arêtes(0), T_Arêtes(1)) ' PGCD des 2 premières arêtes
    For i = 2 To UBound(T_Arêtes)
        Pgcd = Application.Gcd(Pgcd, T_Arêtes(i))
    Next

    ' Calcul du nombre de cubes
    Nb_Cubes = 0
    For i = 1 To UBound(T_Arêtes) / 3
        N = 1
        For j = 0 To 2
            N = N * (T_Arêtes((i - 1) * 3 + j) / Pgcd)
        Next
        Nb_Cubes = Nb_Cubes + N
    Next

    Range("Vos_résultats").Cells(Ligne) = Nb_Cubes
Next Ligne

End Sub

Public Function Nb_Blocs(Str_Blocs) As Byte
Dim i As Byte
For i = 1 To Len(Str_Blocs)
    If Mid(Str_Blocs, i, 1) = "/" Then Nb_Blocs = Nb_Blocs + 1
Next
End Function

Je vous mets ma solution en pièce jointe.

Cordialement

JG CHIO

127defi-1-jg-chio.zip (19.40 Ko)

Bonjour,

et une participation de plus.

J'étais parti sur un truc plus compliqué : nombre mini de cubes avec des cubes les plus gros possibles pfffff...

Private Sub CommandButton_defi_Click()
    For Each c In [A2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 1)
        nbCubes = 0
        bloc = Split(c, "/") ' découpage des blocs
        For i = 0 To UBound(bloc)
            [F1:F3].Offset(, i) = Application.Transpose(Split(bloc(i), "x")) ' tableau des dimensions sur feuille
        Next i
        pgcd = Evaluate("pgcd(" & [F1].CurrentRegion.Address & ")") ' taille bloc max
        For i = 0 To UBound(bloc)
            nbCubes = nbCubes + Evaluate("product(" & [F1:F3].Offset(, i).Address & ")") / pgcd ^ 3 ' nombre de cubes
        Next i
        c.Offset(, 2) = nbCubes
        [F1].CurrentRegion.ClearContents
    Next c
End Sub

En nombre minimum de ligne (1 ligne ) :

Private Sub defi_mini()
    For Each c In [A2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 1): nbCubes = 0: bloc = Split(c, "/"): For i = 0 To UBound(bloc): [F1:F3].Offset(, i) = Application.Transpose(Split(bloc(i), "x")): Next i: For i = 0 To UBound(bloc): nbCubes = nbCubes + Evaluate("product(" & [F1:F3].Offset(, i).Address & ")") / Evaluate("pgcd(" & [F1].CurrentRegion.Address & ")") ^ 3: Next i: c.Offset(, 2) = nbCubes: [F1].CurrentRegion.ClearContents: Next c
End Sub
106defi-1.zip (17.20 Ko)

Bonjour

En voulant tester la macro sur 2010 et 2013 je me suis aperçu qu'elle ne fonctionnait pas sur ces versions

Donc modification du code qui vérifie la version :

Option Explicit

Sub Decoupe()
Dim I As Integer, K As Integer    ' Variable de boucle
Dim J As Long                     ' Variable de boucle pour les lignes dans la page
Dim NombreCube As Long            ' Nombre de cube dans chaque bloc
Dim Bloc                          ' Tableau contenant le nombre de bloc
Dim Dimension                     ' Tableau contenant toutes les dimensions
Dim Arete As Integer              ' Calcul de l'arête maxi du cube
Dim Total As Long                 ' Nombre de cube total dans tous les blocs

  For J = 2 To Range("A" & Rows.Count).End(xlUp).Row            ' Pour toute les lignes
    Dimension = Split(Replace(Range("A" & J), "/", "x"), "x")   ' On place dans un tableau toutes les dimensions de tous les blocs
    If Val(Application.Version) >= 12 Then                      ' Vérification de la version Excel
      Arete = Application.Gcd(Dimension)                        ' Si version 2007 ou plus
    Else
      Arete = Evaluate("PGCD(" & Join(Dimension, ",") & ")")    ' Meilleur moyen d'obtenir le PGCD (pas natif en 2003)
    End If
    Total = 0                                                   ' Initialise la variable
    Bloc = Split(Range("A" & J), "/")                           ' Décompose en bloc
    For I = 0 To UBound(Bloc)                                   ' Pour chaque bloc
      Dimension = Split(Bloc(I), "x")                           ' Les dimensions de ce bloc
      NombreCube = Dimension(0) / Arete                         ' La 1ère dimension donne une quantité de bloc
      For K = 1 To UBound(Dimension)
        NombreCube = NombreCube * Dimension(K) / Arete          ' Cette quantité est multipliée par le nombre de bloc que l'on peut ontenir pour chaque dimension
      Next K
      Total = Total + NombreCube                                ' On totalise le nombre de cube
    Next I
    Range("C" & J) = Total                                      ' On inscrit ce total
  Next J
End Sub

Normalement compatible 2003 - 2010 - 2013

Bonjour Sebastien et tous,

ma version Paritec

Option Explicit

Private Sub CommandButton_defi_Click()
    Dim i&, x, y, n&, res, var, aa, l&, d#, resu&, a&
    With Sheets("Défi")
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            ReDim var(l)
            x = Split(.Cells(i, 1), "/")
            For a = 0 To UBound(x)
                y = Split(x(a), "x")
                For n = 0 To UBound(y)
                    ReDim Preserve var(l): var(l) = y(n): l = l + 1
                Next n
            Next a
            l = 0
            d = Application.WorksheetFunction.Gcd(var)
            For a = 0 To UBound(x)
                y = Split(x(a), "x")
                For n = 0 To UBound(y)
                    If res = 0 Then res = (CDbl(y(n)) / d) Else res = res * (CDbl(y(n)) / d)
                Next n
                resu = resu + res
                res = 0
            Next a
            .Cells(i, 3) = resu: resu = 0
        Next i
    End With
End Sub

a+

papou

94defi-paritec.xlsm (24.38 Ko)

Salut,

voici ma proposition...

Option Explicit
Dim myRange As Range, derLig As Integer, a As Integer, NbB As Integer, myValue As String, b As Integer, myRec As String
Dim Tablo As Variant, mysplit As Variant, c As Integer, d As Integer, mySplit2 As Variant, myGCD As Integer
Dim ii As Long, jj As Long

Private Sub CommandButton_defi_Click()
Application.ScreenUpdating = False
derLig = Range("A" & Rows.Count).End(xlUp).Row

For a = 2 To derLig

    Set myRange = Cells(a, 1)

    myValue = myRange.Value

    NbB = 0
    For b = 1 To Len(myValue)
        myRec = Mid(myValue, b, 1)
        If myRec = "/" Then NbB = NbB + 1
    Next b

    NbB = NbB + 1

    ReDim Tablo(NbB)
    If NbB = 1 Then
        Tablo(1) = myRange.Value
    Else
        mysplit = Split(myRange.Value, "/")
        For c = 1 To NbB
            Tablo(c) = mysplit(c - 1)
        Next c
    End If

    For d = 1 To UBound(Tablo)
        mySplit2 = Split(Tablo(d), "x")
        Cells(d, 8) = mySplit2(0)
        Cells(d, 9) = mySplit2(1)
        Cells(d, 10) = mySplit2(2)
    Next d
    myGCD = Application.WorksheetFunction.Gcd(Cells(1, 8).CurrentRegion)

   d = 1
    ii = 0
    jj = 0
    Do Until IsEmpty(Cells(d, 8))
        ii = Cells(d, 8) / myGCD * Cells(d, 9) / myGCD * Cells(d, 10) / myGCD
        jj = jj + ii
        d = d + 1
    Loop

    myRange.Offset(, 2) = jj

    Set Tablo = Nothing
    Cells(1, 8).CurrentRegion.ClearContents

Next a

Application.ScreenUpdating = True

End Sub

Quand est ce que les résultats seront publiés ?

114d-fixed.xlsm (25.71 Ko)

Bonjour à tous,

Les macros sont maintenant dévoilées ...

L'astuce ici pour réaliser une macro assez courte et sans trop de tableaux était d'utiliser Evaluate pour calculer le résultat (en transformant par exemple 81x72x99/36x45x18 en 81*72*99+36*45*18, voir plus bas).

Mais l'important est avant tout d'avoir réussi à relever le défi avec une macro fonctionnelle. Je suis d'ailleurs bien content que la plupart d'entre-vous n'y ait pas pensé, ça nous permet d'avoir maintenant un beau choix de macros bien différentes ce qui est beaucoup plus intéressant/instructif (et c'est aussi le but recherché)

Bravo à tous les participants


De mon côté, je vous propose différentes solutions :


Résultat (version normale) :

Private Sub CommandButton_defi_Click()

    For ligne = 2 To Range("A1").End(xlDown).Row

        'Côté du cube = plus grand diviseur commun avec la fonction GCD
         cote = WorksheetFunction.Gcd(Split(Replace(Cells(ligne, 1), "x", "/"), "/"))

        'Calcul du résultat = somme de la multiplication des 3 dimensions de chaque bloc, le tout divisé par le côté au cube (comme si l'on divisait chaque dimension par le côté)
         Cells(ligne, 3) = Evaluate(Replace(Replace(Cells(ligne, 1), "x", "*"), "/", "+")) / cote ^ 3

    Next

End Sub

Résultat (version réduite) :

Private Sub CommandButton_defi_Click()
    For l = 2 To 8
        Cells(l, 3) = Evaluate(Replace(Replace(Cells(l, 1), "x", "*"), "/", "+")) / WorksheetFunction.Gcd(Split(Replace(Cells(l, 1), "x", "/"), "/")) ^ 3
    Next
End Sub

Résultat (version détaillée) :

Private Sub CommandButton_defi_Click()

    For ligne = 2 To Range("A1").End(xlDown).Row

        'Cellule à tester
         cellule = Cells(ligne, 1)

        'Remplacement des "x" par des "/" (pour avoir par exemple : 16/8/12/8/20/8)
         liste = Replace(cellule, "x", "/")

        'Entrée de ces valeurs dans un tableau
         tab_liste = Split(liste, "/")

        'Côté du cube = plus grand diviseur commun avec la fonction GCD
         cote = WorksheetFunction.Gcd(tab_liste)

        'Formule (pour avoir par exemple : 16*8*12+8*20*8)
         formule = Replace(Replace(cellule, "x", "*"), "/", "+")

        'Résultat de la formule divisé par le côté au cube (comme si l'on avait divisé chaque valeur par le côté)
         Cells(ligne, 3) = Evaluate(formule) / cote ^ 3

    Next

End Sub

Autre résultat sans utiliser Evaluate (version normale) :

Private Sub CommandButton_defi_Click()

    For ligne = 2 To Range("A1").End(xlDown).Row

        cote = WorksheetFunction.Gcd(Split(Replace(Cells(ligne, 1), "x", "/"), "/")) 'Plus grand diviseur commun
         tab_blocs = Split(Cells(ligne, 1), "/") 'Liste des blocs dans un tableau
         resultat = 0

        For i = 0 To UBound(tab_blocs)
            tab_bloc = Split(tab_blocs(i), "x")  '3 dimensions du bloc dans un tableau
             resultat = resultat + tab_bloc(0) * tab_bloc(1) * tab_bloc(2) / cote ^ 3 'Nombre de cubes pour ce bloc
         Next

        Cells(ligne, 3) = resultat 'Affichage du résultat

    Next

End Sub

Autre résultat sans utiliser Evaluate (version réduite) :

Private Sub CommandButton_defi_Click()
    For l = 2 To 8
        For i = 0 To UBound(Split(Cells(l, 1), "/"))
            Cells(l, 3) = Cells(l, 3) + Split(Split(Cells(l, 1), "/")(i), "x")(0) * Split(Split(Cells(l, 1), "/")(i), "x")(1) * Split(Split(Cells(l, 1), "/")(i), "x")(2) / WorksheetFunction.Gcd(Split(Replace(Cells(l, 1), "x", "/"), "/")) ^ 3
        Next
    Next
End Sub

Autre résultat sans utiliser GCD, compatible avec les vieilles versions d'Excel (version normale) :

Private Sub CommandButton_defi_Click()

    For ligne = 2 To Range("A1").End(xlDown).Row

        'Liste des valeurs
         tab_liste = Split(Replace(Cells(ligne, 1), "x", "/"), "/")

        'Côté du cube = plus grand diviseur commun
         For nb = 1 To 100
            test = True
            For i = 0 To UBound(tab_liste)
                If tab_liste(i) Mod nb <> 0 Then test = False
            Next
            If test Then cote = nb
        Next

        'Calcul du résultat
         Cells(ligne, 3) = Evaluate(Replace(Replace(Cells(ligne, 1), "x", "*"), "/", "+")) / cote ^ 3

    Next

End Sub

Autre résultat sans utiliser GCD, compatible avec les vieilles versions d'Excel (version réduite) :

Private Sub CommandButton_defi_Click()
    For l = 2 To 8
        For n = 1 To 100
            test = True
            For i = 0 To UBound(Split(Replace(Cells(l, 1), "x", "/"), "/"))
                If Split(Replace(Cells(l, 1), "x", "/"), "/")(i) Mod n <> 0 Then test = False
            Next
            If test Then Cells(l, 3) = Evaluate(Replace(Replace(Cells(l, 1), "x", "*"), "/", "+")) / n ^ 3
        Next
    Next
End Sub

Bonjour à tous,

Un seul d'entre nous a pensé à l'astuce du replace() pour calculer directement.

Sans conteste bravo à vba-new, qui de plus, était le 1er à répondre

eric

PS : sébastien fait gaffe, il regarde par-dessus ton épaule je crois...

Bonsoir et bravo à tous

Avec de telles propositions, si j'osais, de telles démonstrations... On a pas finit de faire appel à vous

Merci du temps que vous passez les uns les autres pour nous aider, dans notre quotidien d'excel.

Merci Seb pour ce dynamisme.

et longue vie à EXCEL-PRATIQUE!!!

Leakim

Bonjour forum,

eriiic a écrit :

Un seul d'entre nous a pensé à l'astuce du replace() pour calculer directement.

Sans conteste bravo à vba-new, qui de plus, était le 1er à répondre

Merci eric
eriiic a écrit :

PS : sébastien fait gaffe, il regarde par-dessus ton épaule je crois...

On pourrait le croire, les solutions sont quasi-identiques
Sébastien a écrit :

ça nous permet d'avoir maintenant un beau choix de macros bien différentes ce qui est beaucoup plus intéressant/instructif (et c'est aussi le but recherché)

Effectivement ! Je trouve également intéressant de comprendre quelle démarche suivent les autres pour arriver au même résultat !

C'est ce qui fait la force d'Excel et qui le rend intéressant...

Et tu nous le prouves également Sébastien avec toutes tes propositions

J'ai vu dans ta proposition optimale que tu n'avais pas mis le signe "=". Je ne pensais pas que ça marchait !

Je n'étais donc pas loin

Il fallait aussi savoir que Application.Gcd était une syntaxe possible pour réussir à réduire le nombre de caractères du code

La question que l'on pourrait se poser maintenant : est-il possible de résoudre ce défi en utilisant seulement des formules ?

Rechercher des sujets similaires à "defi vba cubes"