Mettre image automatiquement suivant date

libellule85

XLDnaute Accro
Bonsoir le forum,

J'ai une nouvelle fois besoin de vous. En effet, je recherche une macro qui puisse mettre une image en automatique suivant une date (les jours fériés par exemple).

J'ai une ligne avec une formule pour mettre le jour avec la date par exemple Mercredi 11 (grâce à la formule : ="Mercredi "&TEXTE(($A$1-JOURSEM($A$1;3)+2);"jj") dans une cellule la A1 j'ai =aujourdhui()).

Je pense que vous comprendrez mieux avec mon fichier.

D'avance, merci pour votre aide
 

Pièces jointes

  • Image en automatique libellule85.xlsm
    20.9 KB · Affichages: 20

job75

XLDnaute Barbatruc
Re : Mettre image automatiquement suivant date

Bonsoir libellule85,

Voyez le fichier joint et ces macros :

Code:
Private Sub Worksheet_Activate()
Worksheet_Calculate
End Sub

Private Sub Worksheet_Calculate()
If ActiveSheet.Name <> Me.Name Then Exit Sub
Dim sel As Range, c As Range
Application.ScreenUpdating = False
ActiveCell.Activate
Set sel = Selection
DrawingObjects.Delete 'RAZ
Feuil2.DrawingObjects("Image 1").Copy 'noms à adapter
For Each c In [B5:H5] 'plage à adapter
  If Application.CountIf([Fériés], c) Then
    c(3).Select
    Me.Paste
    Selection.Width = c.Width
  End If
Next
sel.Select
End Sub
Bonne nuit.
 

Pièces jointes

  • Image en automatique libellule85(1).xlsm
    65.9 KB · Affichages: 44
Dernière édition:

job75

XLDnaute Barbatruc
Re : Mettre image automatiquement suivant date

Bonjour libellule85, le forum,

Quelques améliorations dans ce fichier (2).

En particulier le presse-papiers est vidé :

Code:
'---pour vider le presse-papier---
[A1].Copy
Application.CutCopyMode = 0
Bonne journée.
 

Pièces jointes

  • Image en automatique libellule85(2).xlsm
    67.9 KB · Affichages: 41

libellule85

XLDnaute Accro
Re : Mettre image automatiquement suivant date

Re Job75,

Je viens d'ouvrir le deuxième fichier et j'ai deux erreur :

1°) Erreur de compilation : Projet ou bibliothèque introuvable erreur 1.jpg

2°) Impossible d'exécuter le code en mode Arrêt erreur 2.jpg
 

Pièces jointes

  • erreur 1.jpg
    erreur 1.jpg
    52 KB · Affichages: 32
  • erreur 2.jpg
    erreur 2.jpg
    54.5 KB · Affichages: 31

job75

XLDnaute Barbatruc
Re : Mettre image automatiquement suivant date

Re,

Dans VBA => Outils => Références et décocher la référence MANQUANTE.

Je l'avais ajoutée pour faire des essais.

Edit : fichier (2 bis) sans cette référence.

A+
 

Pièces jointes

  • Image en automatique libellule85(2 bis).xlsm
    66.4 KB · Affichages: 22
Dernière édition:

libellule85

XLDnaute Accro
Re : Mettre image automatiquement suivant date

Bonsoir Job75, le forum,

Job 75 j'ai un problème avec tes 2 macros : si j'insère une forme sur ma feuille, celle-ci est supprimée à l'ouverture du fichier. Y a t'il un moyen d'éviter ce problème ?

D'avance merci

Code:
Private Sub Worksheet_Activate()
Worksheet_Calculate
End Sub


Private Sub Worksheet_Calculate()
If ActiveSheet.Name <> Me.Name Then Exit Sub
Dim sel As Range, c As Range
Application.ScreenUpdating = False
ActiveCell.Activate
Set sel = Selection
DrawingObjects.Delete 'RAZ
Feuil2.DrawingObjects("Image 1").Copy 'noms à adapter
For Each c In [B5:H5] 'plage à adapter
  If Application.CountIf([Fériés], c) Then
    c(3).Select
    Me.Paste
    Selection.Width = c.Width
  End If
Next
sel.Select
'---pour vider le presse-papier---
[A1].Copy
Application.CutCopyMode = 0
End Sub
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : Mettre image automatiquement suivant date

Re,

Pour une suppression sélective :

Code:
Private Sub Worksheet_Calculate()
If ActiveSheet.Name <> Me.Name Then Exit Sub
Dim r As Range, sel As Range, o As Object
Set r = [B5:H5] 'plage à adapter
Application.ScreenUpdating = False
ActiveCell.Activate
Set sel = Selection
For Each o In DrawingObjects 'suppression sélective
  If Not Intersect(o.TopLeftCell, r.Rows(3)) Is Nothing Then o.Delete
Next
Feuil2.DrawingObjects("Image 1").Copy 'noms à adapter
For Each r In r
  If Application.CountIf([Fériés], r) Then
    r(3).Select
    Me.Paste
    Selection.Width = r.Width
  End If
Next
sel.Select
'---pour vider le presse-papiers---
[A1].Copy
Application.CutCopyMode = 0
End Sub
Fichier (3).

Bonne soirée.
 

Pièces jointes

  • Image en automatique libellule85(3).xlsm
    67.9 KB · Affichages: 31

Discussions similaires