Affecter une image sous conditions

[maval]

Bonjour,

Je souhaiterai affecter suivant les conditions une image en ligne 14, si l'objectif est réaliser ou pas en fonction des objectifs de la ligne 9/10, les images étant stockées sur l'onglet nommé "Images" du classeur.

D'avance merci à qui pourra m'aider.

Cordialement

Maval

 

[job75]

Re : Affecter une image sous conditions

Bonjour maval,

A placer dans le code de Feuil1 (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cel As Range, ecart
Application.ScreenUpdating = False
Me.DrawingObjects.Delete
For Each cel In [B9,D9,F9,I9]
  If cel <> "" And cel(3) <> "" Then
    ecart = IIf(cel.Column = 9, 2000, 1000)
    If cel(3) >= cel Then
      CopieImage 1, cel
    ElseIf cel - cel(3) <= ecart Then
      CopieImage 2, cel
    Else
      CopieImage 3, cel
    End If
  End If
Next
ActiveCell.Activate
[A1].Copy [A1] 'vide le presse-papier
End Sub

Sub CopieImage(n As Byte, cel As Range)
Sheets("Images").DrawingObjects("Image " & n).Copy
Me.Paste
With cel(6)
  Selection.Top = .Top + (.Height - Selection.Height) / 2
  Selection.Left = .Left + (.Resize(, 2).Width - Selection.Width) / 2
End With
End Sub

Fichier .xls joint.

A+

 

[job75]

Re : Affecter une image sous conditions

Re,

Un peu plus court avec IIf :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cel As Range, ecart, n As Byte
Application.ScreenUpdating = False
Me.DrawingObjects.Delete
For Each cel In [B9,D9,F9,I9]
  If cel <> "" And cel(3) <> "" Then
    ecart = IIf(cel.Column = 9, 2000, 1000)
    n = IIf(cel(3) >= cel, 1, IIf(cel - cel(3) <= ecart, 2, 3))
    Sheets("Images").DrawingObjects("Image " & n).Copy
    Me.Paste
    With cel(6)
      Selection.Top = .Top + (.Height - Selection.Height) / 2
      Selection.Left = .Left + (.Resize(, 2).Width - Selection.Width) / 2
    End With
  End If
Next
ActiveCell.Activate
[A1].Copy [A1] 'vide le presse-papier
End Sub

Fichier (2).

A+

 

[job75]

Re : Affecter une image sous conditions

Re,

L'inconvénient de la Worksheet_SelectionChange c'est qu'on ne peut plus faire de Copier/Coller.

Cette Worksheet_Change n'a pas ce problème :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, ecart, n As Byte
Application.ScreenUpdating = False
Me.DrawingObjects.Delete
For Each cel In [B9,D9,F9,I9]
  If cel <> "" And cel(3) <> "" Then
    ecart = IIf(cel.Column = 9, 2000, 1000)
    n = IIf(cel(3) >= cel, 1, IIf(cel - cel(3) <= ecart, 2, 3))
    Sheets("Images").DrawingObjects("Image " & n).Copy
    Me.Paste
    With cel(6)
      Selection.Top = .Top + (.Height - Selection.Height) / 2
      Selection.Left = .Left + (.Resize(, 2).Width - Selection.Width) / 2
    End With
  End If
Next
ActiveCell.Activate
Application.EnableEvents = False
[A1].Copy [A1] 'vide le presse-papier
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Fichier (3).

A+

 

[Papou-net]

Re : Affecter une image sous conditions

Bonjour maval, job75,

Bien que très "à la bourre", comme j'ai fait par une autre méthode je la propose ici.

J'ai créé sur la feuille 1 des contrôles Image (ActiveX) dans lesquelles je charge des images ("Iconex.jpg) en fonction des résultats. Ces images doivent être placées dans le même répertoire que le classeur, sinon il faut mentionner le chemin dans le code.

Par cette méthode, la feuille 2 peut être supprimée.

Au demandeur de choisir.

Cordialement.

Edit : après décompression, les 4 fichiers doivent être transférés dans un même répertoire sur le DD.

 

[Fo_rum]

Re : Affecter une image sous conditions

Bonjour,

pour le fun (et éviter la manipulation d’images) :
en réduisant les macros comme le fait Job, j’ arrive à ne plus en avoir.
Quelques formules et une MFC peuvent alléger le fichier.
Papou-net, la recherche de fichiers "image" m'a toujours peu inspiré.

 

[maval]

Re : Affecter une image sous conditions

Bonjour Fo_rum, Papou-net, Job75,

Je vous remercie beaucoup du résultat et vous souhaite une excellente journée.

Maval