Autres 2 sujets: 1_Appliquer couleurs à partir de l'onglet "complément" sur calendrier. 2_ Créer 1 boucle d'mages JPEG en auto, type diapo sur Excel 2007

Slavko.R · 6 Mai 2022

Bonjour à toute l'équipe et salutation aux membres du forum

Me revoici avec, cette fois, deux défis en un.
En effet, sur une même feuille de calculs Excel, j'ai deux grands sujets qui me posent problèmes et que je ne puis résoudre seul.

Le premier sujet, concerne une barre de commande que j'ai rajouté en créant l'onglet "COMPLEMENTS".
Cette barre de commande contient un certain nombre de couleurs renvoyant à des évènements.
Ces évènement sont des actions du type 'R.V' chez le médecin, Etc.

L'onglet "compléments" avec la barre de couleurs apparaît et disparait quand je le désire, jusque là tout va.
Par contre, je n'arrive pas à appliquer les évènements (couleurs) de la barre, sur le calendrier.
Voici ce qu'Excel affiche comme message d'erreur, lorsque je clic sur une couleur:

Sachant, toutefois, que ce message ne peut être pris au pied de la lettre.
En effet, le classeur est bel et bien enregistrée pour accepter les macro. (Mais, en binaire plus stable pour mon environnement)

Si quelqu'un à une idée, une soluce, je suis tout ouïe?

Le second sujet, concerne cette fois la mise en place et la réalisation d'une diapositive du type boucle JPEG qui passerait les une derrières les autres les images
que l'on peut apercevoir ci-dessus.
ces images servent, à la fois d'entête et d'habillage esthétique

Sauf que je ne sais si cela est faisable sur un model 2007 de classeur Excel?
Si oui, comment faut t-il faire?

Encore une fois, si quelqu'un à des idées et ou mieux, une solution. Je suis alors, preneur.

D'avance, merci
Je souhaite un grand courage à celui ou ceux qui voudront relever ce défi

Cordialement,
Slav

AtTheOne · 8 Mai 2022

Bonsoir à toutes & à tous, bonsoir @Slavko.R ,
Il doit manquer un module dans ton fichier car la macro Coloriage n'est pas présente dans ton projet !
Amicalement
Alain

Slavko.R · 9 Mai 2022

Salut,

Je te remercie et regarde comment je peux rajouter cela.
Sinon, en ce qui concerne le second sujet, une idée, une suggestion à proposer?

Amicalement,
Slav

AtTheOne · 9 Mai 2022

Bonjour à toutes & à tous, bonjour @Slavko.R
Bon, pour ton projet, il faut enregistrer les événements quelque part dans ton classeur pour que, lors d'un changement de mois ou de début de semaine, les informations de l'ancien mois soient effacées de ton planning et que celles du nouveau mois soient affichées.
Donc premier point
J'ai créé une feuille "Enregistrements" avec un tableau structuré "Records" qui mémorise les événements.
J'ai ensuite créé quatre macros :

coloriage(i) appelée par le ruban "Compléments"

VB:

Sub coloriage(i)

     Dim CellDate As Range, LObj As ListObject
    
     Créneau = (ActiveCell.Row - 6) Mod 5
     Set CellDate = Application.Intersect(ActiveCell.EntireColumn, Feuil1.Rows(ActiveCell.Row).Offset(-Créneau))
     If CellDate Is Nothing Then Exit Sub
    
     Set LObj = Feuil3.ListObjects("Records")
    
     With LObj.ListRows
         If .Count = 0 Then .Add
         If Not IsEmpty(.Item(.Count).Range.Cells(1)) Then .Add
         .Item(.Count).Range.Cells(1).Value = CellDate.Value
         .Item(.Count).Range.Cells(2).Value = Créneau
         .Item(.Count).Range.Cells(3).Value = i
     End With
     With Feuil2.[Couleurs].Cells(i)
          ActiveCell = .Value
          ActiveCell.Interior.Color = .Interior.Color
          ActiveCell.Font.Color = .Font.Color
     End With
    
End Sub

EffacerPlanning qui permet de nettoyer le planning lors des changements de mois

Code:

Sub EffacerPlanning()

     Dim Planning As Range
     Set Planning = Feuil1.[Planning]
     For Each Zone In Planning.Areas
          Zone.ClearContents
          Zone.Interior.Color = xlNone
     Next Zone
    
End Sub

ChangementPlanning qui met à jour le planning lors d'un changement de mois

Code:

Sub ChangementPlanning()

     Dim MaCell As Range, Ligne As Long, Créneau As Byte
     Dim Tb, TbTâches()
     Dim Dc As New Scripting.Dictionary
     Dc.CompareMode = vbTextCompare
     With Feuil3.ListObjects("Records")
          With .Sort
               With .SortFields
                    .Clear
                    .Add2 Key:=Range("Records[Date]"), SortOn:=xlSortOnValues, Order:=xlAscending
                    .Add2 Key:=Range("Records[Créneau]"), SortOn:=xlSortOnValues, Order:=xlAscending
               End With
               .Header = xlYes
               .Apply
          End With
          With .Range
               Tb = .Offset(1).Resize(.Rows.Count - 1).Value2
          End With
     End With
     With Feuil2.[Couleurs]
          ReDim TbTâches(1 To .Count, 1 To 3)
          For i = 1 To .Count
               TbTâches(i, 1) = .Cells(i).Value
               TbTâches(i, 2) = .Cells(i).Interior.Color
               TbTâches(i, 3) = .Cells(i).Font.Color
          Next i
     End With
     Set MaCell = ActiveCell
     DMin = Feuil1.[B6].Value2
     DMax = Feuil1.[H21].Value2
     For i = 1 To UBound(Tb)
          If Tb(i, 1) >= DMin And Tb(i, 1) <= DMax Then
               OffC = (Tb(i, 1) - DMin) Mod 7
               OffL = ((Tb(i, 1) - DMin) \ 7) * 5 + Tb(i, 2)
               Dc(OffL & "-" & OffC) = TbTâches(Tb(i, 3), 1) & Chr(9) & TbTâches(Tb(i, 3), 2) & Chr(9) & TbTâches(Tb(i, 3), 3)
          End If
     Next i
     If Dc.Count > 0 Then
     Clefs = Dc.Keys: Valeurs = Dc.Items
          With Feuil1.[B6]
               For i = 0 To Dc.Count - 1
                    d = Split(Clefs(i), "-")
                    V = Split(Valeurs(i), Chr(9))
                    With .Offset(CInt(d(0)), CInt(d(1)))
                         .Value = V(0): .Interior.Color = V(1): .Font.Color = V(2)
                    End With
               Next
              
          End With
     End If
    
End Sub

MàjPlanning qui enchaîne les deux macros précédentes, appelée par les toupies Année et Mois et l'événement Worksheet_Change (lors d'un changement de début de semaine)

Code:

Sub MàjPlanning()

     Application.EnableEvents = False
     Application.ScreenUpdating = False
     EffacerPlanning
     ChangementPlanning
     Application.ScreenUpdating = True
     Application.EnableEvents = True
    
End Sub

Événement Worksheet_Change de la feuille Planning :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Address = Me.[AnnéeCal].Address Or Target.Address = Me.[MoisCal].Address Or Target.Address = Me.[DébutSemaine].Address Then
          MàjPlanning
     End If
End Sub

Deuxième point ton diaporama

J'ai nommé tes photos de "Bandeau 1" à "Bandeau 9" et j'ai écrit 3 macros pour enchaîner l'affichage de ces photos en utilisant l'instruction OnTime qui permet de lancer une procédure à une date précise ou de stopper cette exécution.

Code:

Public Temps As Date

Sub ChangeBandeau()
    Dim sh As Object
    Application.EnableEvents = False
    Feuil1.[n°_Image] = ((Feuil1.[n°_Image]) Mod 9) + 1
    Set sh = Feuil1.Shapes("Bandeau " & Feuil1.[n°_Image])
    sh.ZOrder msoSendToFront
    Application.EnableEvents = True
End Sub

Sub ExecuteChangeBandeau()
    ChangeBandeau
    Temps = Now + TimeValue("00:00:05")
    Application.OnTime Temps, "ExecuteChangeBandeau"
End Sub

Sub Arrêt()
    Application.OnTime Temps, "ExecuteChangeBandeau", , False
End Sub

J'appelle ExcécuteChangeBandeau dans la procédure Workbook_Open et la procédure Arrêt dans la procédure Workbook_BeforeClose :

Code:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
    On Error Resume Next: Arrêt: On Error GoTo 0
    
End Sub

Private Sub Workbook_Open()
     ExecuteChangeBandeau
End Sub

Voilà teste et penche toi sur le code.
Voir le fichier joint
Amicalement
Alain

Slavko.R · 10 Mai 2022

Salut à toi, magicien du VBA

Je te remercie pour ce travail remarquable.
Sauf, que ça ne fonctionne pas toujours du premier coup.
Surtout lorsque l'on à faire à quelque chose d'aussi pointu et complexe que ce type de programme.

Voici l'erreur qui s'affiche sur mon 'PC', environnement WIN 10 grand public, dans Mdl_Bandeau

Sub ChangeBandeau()
Dim sh As Object
Application.EnableEvents = False
Feuil1.[n°_Image] = ((Feuil1.[n°_Image]) Mod 9) + 1
Set sh = Feuil1.Shapes("Bandeau " & Feuil1.[n°_Image])
sh.ZOrder msoSendToFront
Application.EnableEvents = True
End Sub

"ERREUR COMPILATION: Projet ou bibliothèque introuvable"

Du coup, pas moyen de voir ce que le programme donne et d'étudier en profondeur ce chef d'oeuvre de code.
Toutefois, je vais essayer de comprendre d'où provient le défaut

Amitiés
Slav

AtTheOne · 10 Mai 2022

Bonjour à toutes & à tous, bonjour @Slavko.R
Désolé, j'ai laissé des bug ...

Slavko.R à dit:
sh.ZOrder msoSendToFront

Erreur sur le nom de la constante ! c'est msoBringToFront ou plus simplement 0 donc
sh.ZOrder msoBringToFront
ou
sh.ZOrder 0

Je corrige

Slavko.R à dit:
"ERREUR COMPILATION: Projet ou bibliothèque introuvable"

J'ai mis en référence Microsoft Scripting RunTime pour utiliser un dictionnaire en Early Binding et j'ai oublié de te prévenir !
On essaie en Late Binding en remplaçant dans la procédure ChangementPlanning la ligne
Dim Dc As New Scripting.Dictionary 'Pour Early Binding avec Microsoft Scripting Runtime en Référence
par les deux lignes
Dim Dc As Object 'Pour Late Binding sans Microsoft Scripting Runtime en Référence
Set Dc = CreateObject("Scripting.Dictionary")

Je corrige (mais tu peux essayer en Early Binding en cochant dans Outils, Référence la ressource Microsoft Scripting Runtime)

Voir PJ
Amicalement
Alain

Slavko.R · 11 Mai 2022

Bonjour Alain,
Je pensais qu'on avançait pas à pas dans la bonne direction et que l'on finirait par trouver la solution.
Mais là, je doute.
En effet, un nouveau phénomène c'est mêlé de la partie: "le fichier ne veut plus s'ouvrir correctement"?

D'avance, en te remerciant pour ta patience et ton opiniâtreté
Cordialement
Slav

AtTheOne · 11 Mai 2022

Bonjour à toutes & à tous, bonjour @Slavko.R
Peux-tu cliquer sur débogage, faire une capture d'écran appuyer sur la touche F8 et faire une nouvelle capture d'écran ?
Chez moi aucun problème (Office 2007 ou Office 2021) tout cela fonctionne sans coup férir :

Il manque peut être une ressource dans ta configuration
En plus tes dates sont curieuses :

J'ai fait une petite recherche sur le net et apparemment cette erreur ce produit lorsqu'Excel ne trouve pas une shape que l'on appelle par son nom. Moi j'appelle les Shapes "Bandeau 1" à "Bandeau 9" par leur nom dans la procédure de "diaporama". Vérifie que tes photos dans le bandeau portent bien ces noms.

A bientôt
Amicalement

Alain
PS j'ai corrigé un petit bug sur la date max affichée affichée date le planning (H31 à la place de H21) Voir PJ

Slavko.R · 12 Mai 2022

Bonjour à toute l'équipe et bien sur bonjour Alain

Voici une capture d'écran, voila ce qui ce passe lorsque je télécharge la version en 'PJ'
Et que je tente d'ouvrir ce classeur avec ma version WMS 10

Très amicalement
Slav

Slavko.R · 12 Mai 2022

Salut, c'est encore moi

Maintenant, si j'appuie sur le bouton oui, Pour récupérer la partie lisible, voici ce qui ce passe:

Attends Alain, c'est pas fini.
Pour conclure, voici la suite... et au final, on a ce résultat:

Voilà, je pense que l'on à fait le tour des malfunctions de ce classeur

Très amicalement,
Slav

AtTheOne · 12 Mai 2022

Bonsoir à toutes & à tous, bonsoir @Slavko.R
On va essayer d'éliminer les potentiels problèmes 1 à 1

D'abord disposes-tu de la bibliothèque "Microsoft.Scripting.Runtime" (Sous VBA Outils, Références, cherche cette référence.) Ou essaie le fichier joint "Test DICO.xlsm". Si en appuyant sur le bouton test l'alphabet s'écrit horizontalement à partir de la cellule D5, tu disposes de la ressource, sinon préviens moi je changerai de méthode.

Ensuite, Ouvre le classeur "Planning e sans les macros.xlsm" pour voir s'il n'y a aucun problème dans le classeur lui-même.

Si le classeur s'ouvre normalement, importe le module "VoirShapes.bas"

Et exécutes la macro Nom_Shapes

Si tout ce passe bien, importe les modules "Code Module1.bas", "Code Module2.bas" ,"Code Mdl_Couleurs.bas", "Code Mdl_Bandeau.bas"
Sinon, préviens moi.

Puis "Code Feuil1.cls" et "Code ThisWorkbook.cls" : ces deux importations créent deux modules de classe, transfert le code contenu dans chacun d'eux vers le code de "Feuil1" (Planning) et ThisWorkbook puis supprime les deux modules de classe créés lors de l'importation.

Enregistre le classeur, ferme le et rouvre le, le diaporama devrait fonctionner.

Important : si tu ne disposes pas de la ressource MS Scripting Runtime, les macros ne fonctionneront pas
Il faudra que j'adopte une autre technique qu'utiliser un dictionnaire (j'ai une petite idée pour le faire)
A bientôt
Amicalement
Alain.

Slavko.R · 13 Mai 2022

Bonjour Alain

Je pense que nous progressons sur la cause des défauts de mon classeur et qui m'interdisent de jouir en totalité de son potentiel.

_ J'ai ouvert le fichier en mode "sans macro" et jusque là tout c'est bien déroulé
La feuille s'affiche à l'écran sans mauvaise surprise et sans peine

Mais, je pense que le problème ce situe à hauteur de l'exécution de la MACRO: "Nom_Shapes"
En effet, il ne se passe rien et pire, le: "Code Module1.bas" n'est même pas détecté...

Si toutefois, j'ai bien tout compris et suivi correctement les étapes de ton correctif précis?

Amicalement,
Slav

AtTheOne · 13 Mai 2022

Bonjour à toutes et à tous, bonjour @Slavko.R
A voir ta capture d'écran, non tu n'as pas suivi la démarche que j'imaginais, mais je n'ai sans doute pas été assez précis et je vois que les modules à importer ne sont pas passés en pièces jointes, donc tu ne pouvais pas suivre le mode opératoire !
On va procéder autrement.
Suis ce mode opératoire pas à pas

Télécharge les deux fichiers joints "Test DICO.xlsm" et "Planning f sans les macros.xlsm"
Ouvre dans EXCEL le fichier "Test DICO.xlsm" et clique sur le bouton "Test"
- Si l'alphabet s'écrit horizontalement à partir de la cellule D5, les dictionnaires fonctionnent
- Sinon tu n'as pas la ressource "Scripting Runtime"
- INDIQUE MOI LE RÉSULTAT
Ferme le classeur "Test DICO.xlsm" ouvre le classeur "Planning f sans les macros.xlsm"
Dans VBA, créé un module :

Dans ce nouveau module copie le code suivant (1 macro):

Enrichi (BBcode):

Sub Nom_Shapes()
 Dim i As Byte, Sh As Shape
       For i = 1 To 9
           Set Sh = Feuil1.Shapes("Bandeau " & i)
           Sh.ZOrder 0
           Application.Wait Now + TimeValue("00:00:01")
           MsgBox "Photo Bandeau " & i & " OK"
       Next i
 End Sub

Exécute la macro "Nom_Shapes"
- Si la macro affiche successivement les photos 1 à 9 c'est OK
- Sinon, on a un problème avec les photos nommées de "Bandeau 1" à "Bandeau 9"
- INDIQUE MOI LE RÉSULTAT

SI TOUT C'EST DÉROULÉ CORRECTEMENT ON CONTINUE, SINON ON AVISE DEMAIN

Maintenant on va ajouter les macros définitives

Supprime le module contenant la macro "Nom_Shapes" (sans exporter avant de supprimer)

Dans VBA, crée un module, nomme le "Mdl_Menu", dans ce module copie le code suivant (3 macros) :

Enrichi (BBcode):

Public Sub MakeClipIconCouleur(coul As Long, Optional forme = 6)
    Dim ico As Object
    With ActiveSheet
        Set ico = .Shapes.AddShape(forme, 10, 10, 10, 10)
        With ico
            .DrawingObject.Interior.Color = coul
            .Line.Visible = False
            .CopyPicture
            .Delete
        End With
    End With
End Sub

Sub AfficherBarreMenu()

    Dim X&, A&, Y, Barre As CommandBar, bouton
        X = Round(Feuil2.[Couleurs].Cells.Count / 3): A = 1: Y = 0
        On Error Resume Next
        Set Barre = Application.CommandBars.Add("BarreColoriage" & 1): Barre.Visible = True
        For i = 1 To Feuil2.[Couleurs].Cells.Count
            Y = Y + 1
            If Y = X Then Y = 0: A = A + 1: Set Barre = CommandBars.Add("BarreColoriage" & A): Barre.Visible = True
            Set bouton = Barre.Controls.Add(msoControlButton, , , , True)
            With bouton
                .Caption = Feuil2.[Couleurs].Cells(i)
                .Style = msoButtonIconAndCaption
                MakeClipIconCouleur Feuil2.[Couleurs].Cells(i).Interior.Color
                .PasteFace
                .OnAction = "'Coloriage """ & i & """'"
            End With
        Next

End Sub

Sub EffacerBarreMenu()
    Dim Cbar As CommandBar
    For Each Cbar In Application.CommandBars
        If Cbar.BuiltIn = False Then Cbar.Delete
    Next
End Sub

Crée un nouveau module, nomme le "Mdl_Effacer", dans ce module copie le code suivant (1 macro) :

Enrichi (BBcode):

Sub Supprimer()
       Dim C As Range, Celldate As Range, Créneau As Byte, Tb, i As Long, TbClef, TbDel
       
       If Intersect(Feuil1.[Planning], Selection).Address = Selection.Address Then
           'Tableaux pour la recherche et la suppression dans le Listobject "Records"
           Tb = Feuil3.[Records]: nb = UBound(Tb)
           ReDim TbClef(1 To nb)
           ReDim TbDel(1 To nb)
           For i = 1 To nb
               TbClef(i) = Tb(i, 1) & "¤" & Tb(i, 2)
               TbDel(i) = False
           Next
           
           For Each C In Selection.Cells
               With C
                   If Not IsEmpty(C) Then
                       Créneau = (C.Row - 6) Mod 5
                       Set Celldate = Application.Intersect(C.EntireColumn, Feuil1.Rows(C.Row).Offset(-Créneau))
                       'Marquage de la ligne à supprimer du listObject "Records"
                       idx = -1
                       On Error Resume Next
                       idx = WorksheetFunction.Match(Celldate.Value & "¤" & Créneau, TbClef, 0)
                       TbDel(idx) = True
                       On Error GoTo 0
                   End If
                   'Effacement du contenu et du formatage de la cellule
                   .ClearContents
                   .Interior.Color = xlNone
                   .Font.ColorIndex = xlAutomatic
               End With
           Next C
           'Suppression dans le Listobject "Records"
           With Feuil3.[Records].ListObject
               For i = nb To 1 Step -1
                   If TbDel(i) Then .ListRows(i).Delete
               Next
           End With
       End If
 
 End Sub

Crée un nouveau module, nomme le "Mdl_Couleurs", copie dans le module le code suivant (4 macros)

Enrichi (BBcode):

Sub coloriage(i)
 
       Dim Celldate As Range, LObj As ListObject
      
       Créneau = (ActiveCell.Row - 6) Mod 5
       Set Celldate = Application.Intersect(ActiveCell.EntireColumn, Feuil1.Rows(ActiveCell.Row).Offset(-Créneau))
       If Celldate Is Nothing Then Exit Sub
      
       Set LObj = Feuil3.ListObjects("Records")
      
       With LObj.ListRows
           If .Count = 0 Then .Add
           If Not IsEmpty(.Item(.Count).Range.Cells(1)) Then .Add
           .Item(.Count).Range.Cells(1).Value = Celldate.Value
           .Item(.Count).Range.Cells(2).Value = Créneau
           .Item(.Count).Range.Cells(3).Value = i
       End With
       With Feuil2.[Couleurs].Cells(i)
            ActiveCell = .Value
            ActiveCell.Interior.Color = .Interior.Color
            ActiveCell.Font.Color = .Font.Color
       End With
      
 End Sub
 
Sub EffacerPlanning()
 
       Dim Planning As Range
       Set Planning = Feuil1.[Planning]
       For Each Zone In Planning.Areas
            Zone.ClearContents
            Zone.Interior.Color = xlNone
            Zone.Font.ColorIndex = xlAutomatic
       Next Zone
      
 End Sub
 
Sub ChangementPlanning()
 
       Dim MaCell As Range, Ligne As Long, Créneau As Byte
       Dim Tb, TbTâches()
       Dim Dc As Object                              'Pour Late Binding sans Microsoft Scripting Runtime en Référence
       Set Dc = CreateObject("Scripting.Dictionary")
 '    Dim Dc As New Scripting.Dictionary            'Pour Early Binding avec Microsoft Scripting Runtime en Référence
       Dc.CompareMode = vbTextCompare
       With Feuil3.ListObjects("Records")
            With .Sort
                 With .SortFields
                      .Clear
                      .Add Key:=Range("Records[Date]"), SortOn:=xlSortOnValues, Order:=xlAscending
                      .Add Key:=Range("Records[Créneau]"), SortOn:=xlSortOnValues, Order:=xlAscending
                 End With
                 .Header = xlYes
                 .Apply
            End With
            With .Range
                 Tb = .Offset(1).Resize(.Rows.Count - 1).Value2
            End With
       End With
       With Feuil2.[Couleurs]
            ReDim TbTâches(1 To .Count, 1 To 3)
            For i = 1 To .Count
                 TbTâches(i, 1) = .Cells(i).Value
                 TbTâches(i, 2) = .Cells(i).Interior.Color
                 TbTâches(i, 3) = .Cells(i).Font.Color
            Next i
       End With
       Set MaCell = ActiveCell
       DMin = Feuil1.[B6].Value2
       DMax = Feuil1.[H31].Value2
       For i = 1 To UBound(Tb)
            If Tb(i, 1) >= DMin And Tb(i, 1) <= DMax Then
                 OffC = (Tb(i, 1) - DMin) Mod 7
                 OffL = ((Tb(i, 1) - DMin) \ 7) * 5 + Tb(i, 2)
                 Dc(OffL & "-" & OffC) = TbTâches(Tb(i, 3), 1) & Chr(9) & TbTâches(Tb(i, 3), 2) & Chr(9) & TbTâches(Tb(i, 3), 3)
            End If
       Next i
       If Dc.Count > 0 Then
       Clefs = Dc.Keys: Valeurs = Dc.Items
            With Feuil1.[B6]
                 For i = 0 To Dc.Count - 1
                      d = Split(Clefs(i), "-")
                      V = Split(Valeurs(i), Chr(9))
                      With .Offset(CInt(d(0)), CInt(d(1)))
                           .Value = V(0): .Interior.Color = V(1): .Font.Color = V(2)
                      End With
                 Next
                
            End With
       End If
      
 End Sub
 
Sub MàjPlanning()
 
       Application.EnableEvents = False
       Application.ScreenUpdating = False
       EffacerPlanning
       ChangementPlanning
       Application.ScreenUpdating = True
       Application.EnableEvents = True
      
 End Sub

Crée un nouveau module, nomme le "Mdl_Bandeau", copie dans ce module le code suivant (une déclaration publique, 4 macros):

Enrichi (BBcode):

Public Temps As Date

Sub ChangeBandeau()
      'Passage de la photo suivante au premier plan
      '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
      Dim sh As Object
      Application.EnableEvents = False
      'Incrémentationdu N° de la photo du premier plan
      Feuil1.[n°_Image] = ((Feuil1.[n°_Image]) Mod 9) + 1
      Set sh = Feuil1.Shapes("Bandeau " & Feuil1.[n°_Image])
      'Passage au premier plan
      sh.ZOrder 0
      Application.EnableEvents = True
     
 End Sub
 
Sub ExecuteChangeBandeau()
      'Changement de photo et planification de la prochaine photo
      '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
      ChangeBandeau
      Temps = Now + TimeValue("00:00:03")
      Application.OnTime Temps, "ExecuteChangeBandeau"
     
 End Sub
 
Sub Arrêt()
      'Déplanification du «diaporama»
      '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
      On Error Resume Next
      Application.OnTime Temps, "ExecuteChangeBandeau", , False
      On Error GoTo 0
 End Sub
 
Sub Switch()
     'Bouton ON/OFF du diaporama
     Ctrl = Application.Caller
     If Ctrl = "Bt_Switch" Then
         With Feuil1.Shapes(Ctrl)
             Select Case .DrawingObject.Text
                 Case "STOP"
                     .DrawingObject.Text = "GO"
                     Arrêt
                 Case "GO"
                     .DrawingObject.Text = "STOP"
                     ExecuteChangeBandeau
             End Select
         
         End With
     End If
End Sub

Dans le code de Feuil1 (Planning)

Copie le code suivant (3 macros)

Enrichi (BBcode):

Private Sub Worksheet_Activate()
    AfficherBarreMenu
    Me.Shapes("Bt_Switch").DrawingObject.Text = "STOP"
    ExecuteChangeBandeau
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

     'Si le changement vient d'un élément du calendrier, mettre à jour le planning
     '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
     If Target.Address = Me.[AnnéeCal].Address Or Target.Address = Me.[MoisCal].Address Or Target.Address = Me.[DébutSemaine].Address Then
          MàjPlanning
     End If
    
End Sub

Private Sub Worksheet_Deactivate()
    EffacerBarreMenu
    Arrêt
    Me.Shapes("Bt_Switch").DrawingObject.Text = "GO"
End Sub

Dans le code de ThisWorkbook, copie le code suivant (2 macros)

Enrichi (BBcode):

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    'Retirer le menu Compléments
    EffacerBarreMenu
    
    'Arrêt du «diaporama» dans le Bandeau
    '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    On Error Resume Next: Arrêt: On Error GoTo 0
    Feuil1.Shapes("Bt_Switch").DrawingObject.Text = "GO"

    
End Sub

Private Sub Workbook_Open()

    'Afficher le menu Complément si la feuille active est le planning
    If ActiveSheet.Name = "Planning" Then AfficherBarreMenu
    
    'Début du «diaporama» dans le Bandeau
    '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    Feuil1.Shapes("Bt_Switch").DrawingObject.Text = "STOP"
    ExecuteChangeBandeau
    
End Sub

Enregistre le classeur sous un nouveau nom, ferme le rouvre le, ça devrait fonctionner

En espérant que tu puisses aller au bout ...
Amicalement
A demain
Alain

Slavko.R · 14 Mai 2022

Bonjour Alain
Tu m'excuses, si je ne suis pas prompts à répondre de suite.
J'essaye de faire au mieux et de trouver les meilleurs compromis, entre mon travail et mes retours espacés dans le temps sur ce forum.

En claire,
Je vois le travail que tu as réalisé dans l'optique de poursuivre le sauvetage de ce projet.
D'ailleurs, au passage, c'est un gros et beau travail, chapeau!

De fait, je vois également qu'il y a pain sur la planche...
Cela risque donc, de me prendre un moment.
Je vais devoir donc, consacrer une bonne partie de mon temps libre à sauver ce projet, coute que coute, avec cette nouvelle "check_list" de consignes que tu proposes

Mais, n'aie crainte, je ne lâche pas l'affaire et te ferai signe si quelque chose ne va pas
En bref, je me mets au turbin dès que je le peux...

Respectueusement,
Slav

Slavko.R · 17 Mai 2022

Bonjour à toute la communauté et surtout à toi, Alain grand magicien du VBA

Merci pour ton aide et plus que cela: Ton accompagnement!

Tu n'as pas hésité à m'accompagner dans cette démarche en prenant complètement en charge et à distance le dépannage de ce projet et je t'en suis infiniment redevable.

Il s'avère que cette procédure répond complètement à la problématique et solutionne tout en un clin d'œil ou devrai-je dire: En un clic, le temps d'enregistrer ton travail une fois copié complétement selon ta méthode et en suivant pas à pas tes instructions.

Maintenant, c'est "GOOD" mon projet est achevé et il fonctionne à merveille, grâce à toi et toute cette équipe dynamique.

Merci du fond du cœur
Slav

Autres 2 sujets: 1_Appliquer couleurs à partir de l'onglet "complément" sur calendrier. 2_ Créer 1 boucle d'mages JPEG en auto, type diapo sur Excel 2007

Slavko.R

XLDnaute Nouveau

Pièces jointes

AtTheOne

XLDnaute Accro

Slavko.R

XLDnaute Nouveau

AtTheOne

XLDnaute Accro

Pièces jointes

Slavko.R

XLDnaute Nouveau

AtTheOne

XLDnaute Accro

Pièces jointes

Slavko.R

XLDnaute Nouveau

AtTheOne

XLDnaute Accro

Pièces jointes

Slavko.R

XLDnaute Nouveau

Slavko.R

XLDnaute Nouveau

AtTheOne

XLDnaute Accro

Pièces jointes

Slavko.R

XLDnaute Nouveau

AtTheOne

XLDnaute Accro

Pièces jointes

Slavko.R

XLDnaute Nouveau

Slavko.R

XLDnaute Nouveau

Discussions similaires