Mettre image automatiquement suivant date

[libellule85]

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

 

[job75]

Re : Mettre image automatiquement suivant date

Bonsoir libellule85,

Voyez le fichier joint et ces macros :

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.

 

[libellule85]

Re : Mettre image automatiquement suivant date

Bonjour Job75,

Une nouvelle fois, un grand grand merci pour ton aide, c'est exactement ce que je recherchais.

Bonne journée

 

[job75]

Re : Mettre image automatiquement suivant date

Bonjour libellule85, le forum,

Quelques améliorations dans ce fichier (2).

En particulier le presse-papiers est vidé :

'---pour vider le presse-papier---
[A1].Copy
Application.CutCopyMode = 0

Bonne journée.

 

[libellule85]

Re : Mettre image automatiquement suivant date

Re,

Merci pour ce complément

 

[libellule85]

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

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

 

[job75]

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+

 

[libellule85]

Re : Mettre image automatiquement suivant date

Re,

J'ai décoché la référence manquante et cela fonctionne impeccable.

Encore merci pour ton aide

 

[libellule85]

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

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

 

[job75]

Re : Mettre image automatiquement suivant date

Re,

Pour une suppression sélective :

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.

 

[libellule85]

Re : Mettre image automatiquement suivant date

re,

à nouveau un très grand merci pour ton aide, c'est vraiment sympa.

Bonne soirée