Bonjour a tous et toutes, forum bonjour

Voila ce code permets de faire défiler la date en A1 et semaine jour avec le suivi couleur des majuscules, ca marche mais on devrait pouvoir le faire plus cours, et en plus ca sautille un peu en A2.

Si quelqu'un veut bien SVP pour une cure d'amaigrissement du code.

Merci a vous et de votre temps
Je vous souhaite une bonne fin d'après midi

Raymond Macro se lance par "Defile"

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Option Explicit
Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Sub Defile()
Dim X, Y1, Y2, Z1, Z2 As Long: Dim OldY1, OldY2, i As Long: Dim C As Range
 
[A1] = Application.Proper(Format(Date, "dddd dd mmmm yyyy    "))
[A2] = "Semaine: " & DatePart("ww", Date, vbMonday) & "     " & _
        DatePart("y", Date, vbMonday) & " ième Jour de l" & Chr(180) & "année" & "     "
With [A1:A2].Font
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With
X = 1
Y1 = InStr(InStr([A1], " ") + 2, [A1], " ") + 1
Y2 = InStr(InStr([A2], " ") + 12, [A2], " ") + 1
OldY1 = Y1: OldY2 = Y2
Z1 = Len([A1]): Z2 = Len([A2])
Custom [A1:A2].Characters(X, 1)
Custom [A1].Characters(Y1, 1): Custom [A2].Characters(Y2, 1)
 
'*** CODE POUR LE DEFILEMENT DES DEUX MESSAGES CELLULES A1/A2
Set C = [A1]                           'Message de la date A1
Standard C: X = Z1 + 1
For i = 1 To 45                        'Durée rotation date
X = X - 1
If X = 0 Then
X = Z1: Standard C
End If
Y1 = Y1 - 1
If Y1 = 0 Then
Y1 = Z1: Standard C
End If
C = Right(C, Z1 - 1) + Left(C, 1)
Custom C.Characters(X, 1): Custom C.Characters(Y1, 1)
Sleep 140                              'Vitesse rotation date
Next i
C = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))
Standard C
Custom C.Characters(1, 1): Custom C.Characters(OldY1, 1)
 
Sleep 1100                             'Tempo 2 secondes environ
 
Set C = [A2]                           'Message semaine et jour A2
Standard C: X = Z2 + 1
For i = 1 To 45                        'Durée rotation semaine
X = X - 1
If X = 0 Then
X = Z2: Standard C
End If
Y2 = Y2 - 1
If Y2 = 0 Then
Y2 = Z2: Standard C
End If
C = Right(C, Z2 - 1) + Left(C, 1)
Custom C.Characters(X, 1): Custom C.Characters(Y2, 1)
Sleep 140                              'Vitesse rotation semaine
Next i
C = "Semaine: " & DatePart("ww", Date, vbMonday) & "     " & _
     DatePart("y", Date, vbMonday) & " ième Jour de l" & Chr(180) & "année"
Standard C
Custom C.Characters(1, 1): Custom C.Characters(OldY2, 1)
End Sub
 
Sub Standard(ByRef R As Range)
With R.Font
.ColorIndex = 0
.Bold = False
End With
End Sub
 
Sub Custom(ByRef Ch As Characters)
With Ch.Font
.FontStyle = "Gras"
.ColorIndex = 3
End With
End Sub