Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Sub Colorier pour Paul V

Sub Colorier pour Paul V

2 réponses
Avatar
Guy72
Bonjour Paul
A propos de la Macro Colorier.
Merci encore.
Rasure toi elle est parfaite, je voulais savoir s'il était possible de faire
ces deux motifs.
Est-il possible d'éviter (quand elle démarre), d effacer la couleur du motif
existant car j'ai un fond coloré.
Est-il possible d'ajouter la macro suivante de manière qu'elle fonctionne en
même temps (c'est un texte clignotant "Bravo !!!"
Sub Bravo()
'Michel Pierron, mpfe
Const Texte As String = "Bravo !!!"
Dim i As Integer

For i = 1 To 20
'Le premier N° est la ligne
'Le deuxième N° est la colonne
Cells(49, 57) = Texte
Call Flash_Sequence
Next i
End Sub

Private Sub Flash_Sequence()
Dim n As Byte, Start As Variant

For n = 1 To 10
Start = Timer
Do While Timer < Start + 1 / 50
Loop
If n Mod 5 = 0 Then Cells(49, 57) = ""
Next n
End Sub


Cordialement
Guy
Signaler un problème avec ce contenu

2 réponses

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
Paul V
Hello Guy,

J'avais pas vu ton message.
Ci-dessous un petit bricolage pour ce que tu sembles vouloir.
J'ai pas repris la macro de Michel car il aurait fallu synchroniser les
boucles et je trouvais que c'était une perte de temps. D'autre part, je
préfère mon Bravo au sien ;-)

Tu peux règler tous les paramètres pour les vitesses, grandeurs, etc.

Pour ton problème de couleur, remplace partout (8 fois si j'ai bien compté)
xlColorIndexAutomatic par xlcolorindexnone pour retrouver le blanc origional
ou par la réf de la couleur que tu avais avant (VByellow pour le jaune,
vbred pour le rouge ou le code correspondant.)

Voici mon code

Sub Colorier()
On Error Resume Next
t2 = 1000000
For nb = 1 To 10
For i = 1 To 46
m = m + 1
ActiveCell.Offset(0, i).Interior.ColorIndex = 6
ActiveCell.Offset(46, 46 - i).Interior.ColorIndex = 6
ActiveCell.Offset(i, 46).Interior.ColorIndex = 6
ActiveCell.Offset(46 - i, 0).Interior.ColorIndex = 6
oldcell1.Interior.ColorIndex = xlColorIndexAutomatic
oldcell2.Interior.ColorIndex = xlColorIndexAutomatic
oldcell3.Interior.ColorIndex = xlColorIndexAutomatic
oldcell4.Interior.ColorIndex = xlColorIndexAutomatic
Set oldcell1 = ActiveCell.Offset(0, i)
Set oldcell2 = ActiveCell.Offset(46, 46 - i)
Set oldcell3 = ActiveCell.Offset(i, 46)
Set oldcell4 = ActiveCell.Offset(46 - i, 0)
If m Mod 5 = 0 Then
If m Mod 10 = 0 Then
Selection.ShapeRange.Delete
Else
ActiveSheet.Shapes.AddTextEffect(msoTextEffect16, "BRAVO", "Arial
Black", 36# _
, msoFalse, msoFalse, 543#, 280.5).Select
Selection.ShapeRange.ScaleWidth 1.94, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 2.72, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleWidth 1.35, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.56, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft -154.5
Selection.ShapeRange.IncrementTop -47.25
End If
End If
For t = 1 To t2
Next t
Next i
Selection.ShapeRange.Delete
t2 = t2 - 50000
Next nb
oldcell1.Interior.ColorIndex = xlColorIndexAutomatic
oldcell2.Interior.ColorIndex = xlColorIndexAutomatic
oldcell3.Interior.ColorIndex = xlColorIndexAutomatic
oldcell4.Interior.ColorIndex = xlColorIndexAutomatic
End Sub

Il est pas très beau ni très optimisé mais il marche ;-) et j'ai pas trop le
temps.

Bon amusement à toi et à ton petit fils

Paul V aka Santa Klaus V


"Guy72" a écrit dans le message de news:

Bonjour Paul
A propos de la Macro Colorier.
Merci encore.
Rasure toi elle est parfaite, je voulais savoir s'il était possible de
faire ces deux motifs.
Est-il possible d'éviter (quand elle démarre), d effacer la couleur du
motif existant car j'ai un fond coloré.
Est-il possible d'ajouter la macro suivante de manière qu'elle fonctionne
en même temps (c'est un texte clignotant "Bravo !!!"
Sub Bravo()
'Michel Pierron, mpfe
Const Texte As String = "Bravo !!!"
Dim i As Integer

For i = 1 To 20
'Le premier N° est la ligne
'Le deuxième N° est la colonne
Cells(49, 57) = Texte
Call Flash_Sequence
Next i
End Sub

Private Sub Flash_Sequence()
Dim n As Byte, Start As Variant

For n = 1 To 10
Start = Timer
Do While Timer < Start + 1 / 50
Loop
If n Mod 5 = 0 Then Cells(49, 57) = ""
Next n
End Sub


Cordialement
Guy



Avatar
Guy72
Bonsoir Paul
Merci Impec ça marche.
Et merci encore, peut être A + pour des problème plus sérieux.
Baye Baye
Cordialement
Guy


"Paul V" a écrit dans le message de news:

Hello Guy,

J'avais pas vu ton message.
Ci-dessous un petit bricolage pour ce que tu sembles vouloir.
J'ai pas repris la macro de Michel car il aurait fallu synchroniser les
boucles et je trouvais que c'était une perte de temps. D'autre part, je
préfère mon Bravo au sien ;-)

Tu peux règler tous les paramètres pour les vitesses, grandeurs, etc.

Pour ton problème de couleur, remplace partout (8 fois si j'ai bien
compté) xlColorIndexAutomatic par xlcolorindexnone pour retrouver le blanc
origional ou par la réf de la couleur que tu avais avant (VByellow pour le
jaune, vbred pour le rouge ou le code correspondant.)

Voici mon code

Sub Colorier()
On Error Resume Next
t2 = 1000000
For nb = 1 To 10
For i = 1 To 46
m = m + 1
ActiveCell.Offset(0, i).Interior.ColorIndex = 6
ActiveCell.Offset(46, 46 - i).Interior.ColorIndex = 6
ActiveCell.Offset(i, 46).Interior.ColorIndex = 6
ActiveCell.Offset(46 - i, 0).Interior.ColorIndex = 6
oldcell1.Interior.ColorIndex = xlColorIndexAutomatic
oldcell2.Interior.ColorIndex = xlColorIndexAutomatic
oldcell3.Interior.ColorIndex = xlColorIndexAutomatic
oldcell4.Interior.ColorIndex = xlColorIndexAutomatic
Set oldcell1 = ActiveCell.Offset(0, i)
Set oldcell2 = ActiveCell.Offset(46, 46 - i)
Set oldcell3 = ActiveCell.Offset(i, 46)
Set oldcell4 = ActiveCell.Offset(46 - i, 0)
If m Mod 5 = 0 Then
If m Mod 10 = 0 Then
Selection.ShapeRange.Delete
Else
ActiveSheet.Shapes.AddTextEffect(msoTextEffect16, "BRAVO", "Arial
Black", 36# _
, msoFalse, msoFalse, 543#, 280.5).Select
Selection.ShapeRange.ScaleWidth 1.94, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 2.72, msoFalse,
msoScaleFromBottomRight
Selection.ShapeRange.ScaleWidth 1.35, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.56, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft -154.5
Selection.ShapeRange.IncrementTop -47.25
End If
End If
For t = 1 To t2
Next t
Next i
Selection.ShapeRange.Delete
t2 = t2 - 50000
Next nb
oldcell1.Interior.ColorIndex = xlColorIndexAutomatic
oldcell2.Interior.ColorIndex = xlColorIndexAutomatic
oldcell3.Interior.ColorIndex = xlColorIndexAutomatic
oldcell4.Interior.ColorIndex = xlColorIndexAutomatic
End Sub

Il est pas très beau ni très optimisé mais il marche ;-) et j'ai pas trop
le temps.

Bon amusement à toi et à ton petit fils

Paul V aka Santa Klaus V


"Guy72" a écrit dans le message de news:

Bonjour Paul
A propos de la Macro Colorier.
Merci encore.
Rasure toi elle est parfaite, je voulais savoir s'il était possible de
faire ces deux motifs.
Est-il possible d'éviter (quand elle démarre), d effacer la couleur du
motif existant car j'ai un fond coloré.
Est-il possible d'ajouter la macro suivante de manière qu'elle fonctionne
en même temps (c'est un texte clignotant "Bravo !!!"
Sub Bravo()
'Michel Pierron, mpfe
Const Texte As String = "Bravo !!!"
Dim i As Integer

For i = 1 To 20
'Le premier N° est la ligne
'Le deuxième N° est la colonne
Cells(49, 57) = Texte
Call Flash_Sequence
Next i
End Sub

Private Sub Flash_Sequence()
Dim n As Byte, Start As Variant

For n = 1 To 10
Start = Timer
Do While Timer < Start + 1 / 50
Loop
If n Mod 5 = 0 Then Cells(49, 57) = ""
Next n
End Sub


Cordialement
Guy