Objectif du classeur excel =C3=A0 terme =3D "dessiner" des droites gradu=C3=
=A9es dont:
1. la graduation s'adapte automatiquement en fonction du d=C3=A9nominateur =
d'une fraction.
2. sous lesquelles je devrai faire appara=C3=AEtre, al=C3=A9atoirement plac=
=C3=A9s, 10 rep=C3=A8res (genre fl=C3=A8che =E2=86=91) en face d'une gradua=
tion pr=C3=A9c=C3=A9demment dessin=C3=A9e.
3. Sous chacun de ces rep=C3=A8res la fraction correspondante.
Contraintes : d=C3=A9nominateur compris entre 2 et 10 maximum
Affichage des droites ainsi construites sur feuille A4 paysage
Actuellement, j'ai r=C3=A9ussi =C3=A0 fabriquer mes droites (sur une feuill=
e (Feuil3)) en utilisant le formatage conditionnel sur 4 lignes avec des fo=
rmules du type: =3DMOD(COLONNE();$DW$1/2)=3D0 et en pla=C3=A7ant des bordur=
es droites ou non.
Ces droites sont donc fabriqu=C3=A9es =C3=A0 la vol=C3=A9e en fonction de l=
a cellule $DW$1 qui repr=C3=A9sente le d=C3=A9nominateur.
Sur une autre feuille("graduation"), j'ai cr=C3=A9=C3=A9 les nombres qui s'=
afficheront au dessus des graduations repr=C3=A9sentant les unit=C3=A9s (co=
mme sur une r=C3=A8gle).
A chaque d=C3=A9nominateur correspond donc une ligne de le feuille ("gradua=
tion").
A l'aide d'une macro, je copie la bonne s=C3=A9rie de graduation depuis la =
feuille graduation vers la feuil3:
Dans la Feuil3:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$DW$1")) Is Nothing Then
Application.ScreenUpdating =3D False
Call FormatTab
Application.ScreenUpdating =3D True
End If
End Sub
Dans un module:
Sub FormatTab()
Application.ScreenUpdating =3D False
Application.EnableEvents =3D False
=20
Select Case Range("$DW$1").Value
Case 10
Application.Goto Reference:=3D"grad10"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 9
Application.Goto Reference:=3D"grad9"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 8
Application.Goto Reference:=3D"grad8"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 7
Application.Goto Reference:=3D"grad7"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 6
Application.Goto Reference:=3D"grad6"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 5
Application.Goto Reference:=3D"grad5"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 4
Application.Goto Reference:=3D"grad4"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 3
Application.Goto Reference:=3D"grad3"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
Case 2
Application.Goto Reference:=3D"grad2"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:=3D"graduation"
ActiveSheet.Paste
End Select
Application.ScreenUpdating =3D True
Application.EnableEvents =3D True
End Sub
1=C3=A8re question
Peut-on faire la m=C3=AAme chose sans macro? et comment?
Peut-on all=C3=A9ger cette macro obtenue par enregistrement?
2=C3=A8me question
Comment faire pour ins=C3=A9rer ces fl=C3=A8ches sous la droite et surtout =
les fractions? L=C3=A0, je s=C3=A8che...
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Pascal Scalpa
Voilà le code de la macro qui fait le bouleau comme voulu... mais c'est t rès lourd! Y a-t-il moyen de faire plus élégant afin que la feuille n e clignote pas pendant sa construction par exemple? denominateur c'est le nom de la cellule $DW$1 que je ne sais pas toujours a ppeler comme il faut dans le code
Select Case Range("$DW$1").Value Case 10 Application.Goto Reference:="grad10" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 9 Application.Goto Reference:="grad9" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 8 Application.Goto Reference:="grad8" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 7 Application.Goto Reference:="grad7" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 6 Application.Goto Reference:="grad6" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 5 Application.Goto Reference:="grad5" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 4 Application.Goto Reference:="grad4" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 3 Application.Goto Reference:="grad3" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 2 Application.Goto Reference:="grad2" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste
End Select
Application.ScreenUpdating = True Application.EnableEvents = True End Sub
Sub RemplissageAleatoire2(Plage As Range, Plage2 As Range, Plage3 As Range, NbFleche As Integer) ' a partir du code ici http://excel.developpez.com/faq/?page=FonctionsAle atoires#CellulesAleatoiresPlage Dim Tableau As Collection Dim Cell As Range Dim Tableau2 As Collection Dim Cell2 As Range Dim Tableau3 As Collection Dim Cell3 As Range Dim i As Integer, j As Integer
'Vérifie si le nombre de cellules est supérieur au nombre de flèc hes à insérer. If Plage.Cells.Count < NbFleche Then Exit Sub If Plage2.Cells.Count < NbFleche Then Exit Sub If Plage3.Cells.Count < NbFleche Then Exit Sub 'suppression des anciennes données 'Cells.Clear Plage.Cells.Clear Plage2.Cells.Clear Plage3.Cells.Clear
'Les flèches Set Tableau = New Collection For Each Cell In Plage Tableau.Add Cell.Address Next Cell 'Le numérateur Set Tableau2 = New Collection For Each Cell2 In Plage2 Tableau2.Add Cell2.Address Next Cell2 'Le dénominateur Set Tableau3 = New Collection For Each Cell3 In Plage3 Tableau3.Add Cell3.Address Next Cell3
For j = 1 To NbFleche Randomize DoEvents i = Int(((Tableau.Count - 2) * Rnd)) + 1 'Insérer les flèches Range(Tableau(i), Tableau(i + 1)).Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Range(Tableau(i), Tableau(i + 1)) = ChrW(8593) Tableau.Remove i Tableau.Remove i + 1
Voilà le code de la macro qui fait le bouleau comme voulu... mais c'est t rès lourd! Y a-t-il moyen de faire plus élégant afin que la feuille n e clignote pas pendant sa construction par exemple?
denominateur c'est le nom de la cellule $DW$1 que je ne sais pas toujours a ppeler comme il faut dans le code
Select Case Range("$DW$1").Value
Case 10
Application.Goto Reference:="grad10"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 9
Application.Goto Reference:="grad9"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 8
Application.Goto Reference:="grad8"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 7
Application.Goto Reference:="grad7"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 6
Application.Goto Reference:="grad6"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 5
Application.Goto Reference:="grad5"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 4
Application.Goto Reference:="grad4"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 3
Application.Goto Reference:="grad3"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
Case 2
Application.Goto Reference:="grad2"
Selection.Copy
Sheets("Feuil3").Select
Application.Goto Reference:="graduation"
ActiveSheet.Paste
End Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub RemplissageAleatoire2(Plage As Range, Plage2 As Range, Plage3 As Range, NbFleche As Integer)
' a partir du code ici http://excel.developpez.com/faq/?page=FonctionsAle atoires#CellulesAleatoiresPlage
Dim Tableau As Collection
Dim Cell As Range
Dim Tableau2 As Collection
Dim Cell2 As Range
Dim Tableau3 As Collection
Dim Cell3 As Range
Dim i As Integer, j As Integer
'Vérifie si le nombre de cellules est supérieur au nombre de flèc hes à insérer.
If Plage.Cells.Count < NbFleche Then Exit Sub
If Plage2.Cells.Count < NbFleche Then Exit Sub
If Plage3.Cells.Count < NbFleche Then Exit Sub
'suppression des anciennes données
'Cells.Clear
Plage.Cells.Clear
Plage2.Cells.Clear
Plage3.Cells.Clear
'Les flèches
Set Tableau = New Collection
For Each Cell In Plage
Tableau.Add Cell.Address
Next Cell
'Le numérateur
Set Tableau2 = New Collection
For Each Cell2 In Plage2
Tableau2.Add Cell2.Address
Next Cell2
'Le dénominateur
Set Tableau3 = New Collection
For Each Cell3 In Plage3
Tableau3.Add Cell3.Address
Next Cell3
For j = 1 To NbFleche
Randomize
DoEvents
i = Int(((Tableau.Count - 2) * Rnd)) + 1
'Insérer les flèches
Range(Tableau(i), Tableau(i + 1)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range(Tableau(i), Tableau(i + 1)) = ChrW(8593)
Tableau.Remove i
Tableau.Remove i + 1
Voilà le code de la macro qui fait le bouleau comme voulu... mais c'est t rès lourd! Y a-t-il moyen de faire plus élégant afin que la feuille n e clignote pas pendant sa construction par exemple? denominateur c'est le nom de la cellule $DW$1 que je ne sais pas toujours a ppeler comme il faut dans le code
Select Case Range("$DW$1").Value Case 10 Application.Goto Reference:="grad10" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 9 Application.Goto Reference:="grad9" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 8 Application.Goto Reference:="grad8" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 7 Application.Goto Reference:="grad7" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 6 Application.Goto Reference:="grad6" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 5 Application.Goto Reference:="grad5" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 4 Application.Goto Reference:="grad4" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 3 Application.Goto Reference:="grad3" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste Case 2 Application.Goto Reference:="grad2" Selection.Copy Sheets("Feuil3").Select Application.Goto Reference:="graduation" ActiveSheet.Paste
End Select
Application.ScreenUpdating = True Application.EnableEvents = True End Sub
Sub RemplissageAleatoire2(Plage As Range, Plage2 As Range, Plage3 As Range, NbFleche As Integer) ' a partir du code ici http://excel.developpez.com/faq/?page=FonctionsAle atoires#CellulesAleatoiresPlage Dim Tableau As Collection Dim Cell As Range Dim Tableau2 As Collection Dim Cell2 As Range Dim Tableau3 As Collection Dim Cell3 As Range Dim i As Integer, j As Integer
'Vérifie si le nombre de cellules est supérieur au nombre de flèc hes à insérer. If Plage.Cells.Count < NbFleche Then Exit Sub If Plage2.Cells.Count < NbFleche Then Exit Sub If Plage3.Cells.Count < NbFleche Then Exit Sub 'suppression des anciennes données 'Cells.Clear Plage.Cells.Clear Plage2.Cells.Clear Plage3.Cells.Clear
'Les flèches Set Tableau = New Collection For Each Cell In Plage Tableau.Add Cell.Address Next Cell 'Le numérateur Set Tableau2 = New Collection For Each Cell2 In Plage2 Tableau2.Add Cell2.Address Next Cell2 'Le dénominateur Set Tableau3 = New Collection For Each Cell3 In Plage3 Tableau3.Add Cell3.Address Next Cell3
For j = 1 To NbFleche Randomize DoEvents i = Int(((Tableau.Count - 2) * Rnd)) + 1 'Insérer les flèches Range(Tableau(i), Tableau(i + 1)).Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Range(Tableau(i), Tableau(i + 1)) = ChrW(8593) Tableau.Remove i Tableau.Remove i + 1