Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Macro pour copier une plage de cellules (nomm

Macro pour copier une plage de cellules (nomm

1 réponse
Avatar
scalpa98
Bonjour

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...

Merci de votre aide.
pascal
Signaler un problème avec ce contenu

1 réponse

Supprimer
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
Avatar
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

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