Macro pour copier une plage de cellules (nomm

Le
scalpa98
Bonjour

Objectif du classeur excel à terme = "dessiner" des droites graduÃ=
©es dont:
1. la graduation s'adapte automatiquement en fonction du dénominateur =
d'une fraction.
2. sous lesquelles je devrai faire apparaître, aléatoirement plac=
és, 10 repères (genre flèche ↑) en face d'une gradua=
tion précédemment dessinée.
3. Sous chacun de ces repères la fraction correspondante.

Contraintes : dénominateur compris entre 2 et 10 maximum

Affichage des droites ainsi construites sur feuille A4 paysage

Actuellement, j'ai réussi à fabriquer mes droites (sur une feuill=
e (Feuil3)) en utilisant le formatage conditionnel sur 4 lignes avec des fo=
rmules du type: =MOD(COLONNE();$DW$1/2)=0 et en plaçant des bordur=
es droites ou non.
Ces droites sont donc fabriquées à la volée en fonction de l=
a cellule $DW$1 qui représente le dénominateur.
Sur une autre feuille("graduation"), j'ai créé les nombres qui s'=
afficheront au dessus des graduations représentant les unités (co=
mme sur une règle).
A chaque dénominateur correspond donc une ligne de le feuille ("gradua=
tion").
A l'aide d'une macro, je copie la bonne série 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 = False
Call FormatTab
Application.ScreenUpdating = True
End If
End Sub

Dans un module:

Sub FormatTab()

Application.ScreenUpdating = False
Application.EnableEvents = False

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

1ère question
Peut-on faire la même chose sans macro? et comment?
Peut-on alléger cette macro obtenue par enregistrement?

2ème question
Comment faire pour insérer ces flèches sous la droite et surtout =
les fractions? Là, je sèche

Merci de votre aide.
pascal
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Pascal Scalpa
Le #25981802
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

Sub Test2()
Application.ScreenUpdating = False
Application.EnableEvents = False
FormatTab
RemplissageAleatoire2 Range("A8:DT8"), Range("A9:DT9"), Range("A10:DT10 "), 10
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Sub FormatTab()
'
'
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("$DW$1").Value = Int((9 * Rnd)) + 2 'alea.entre.bornes(2, 10)


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

'Insérer les numérateurs
Range(Tableau2(i), Tableau2(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
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range(Tableau2(i), Tableau2(i + 1)) = "=COLUMN()"
'ActiveCell.FormulaR1C1 = "=CONCATENATE(COLUMN(),""/"",denomina teur)"
Tableau2.Remove i
Tableau2.Remove i + 1

'Insérer les dénominateurs
Range(Tableau3(i), Tableau3(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(Tableau3(i), Tableau3(i + 1)) = "Þnominateur"
Tableau3.Remove i
Tableau3.Remove i + 1


DoEvents
Next j

End Sub
Sub Macro5()
'
' Macro5 Macro
'

'
Range("Y16:Z16").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range("Y17:Z17").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("AC17").Select
ActiveCell.Offset(-1, 0).Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.Offset(1, 0).Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
End Sub
Publicité
Poster une réponse
Anonyme