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) :
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) :
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.
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
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
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
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 ?
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,
Merci ericeriiic 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
On pourrait le croire, les solutions sont quasi-identiqueseriiic a écrit :PS : sébastien fait gaffe, il regarde par-dessus ton épaule je crois...
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 ?