Exécution d'un code VBA appliqué à des cellules sélectionnées

[Renaud22]

Bonjour à tous,

J'ai une base de données ("Base de données - 26-02-14_V1.zip" ci-joint) dans laquelle je dois y insérer des images. Par exemple : lorsque je clique sur la cellule G6, un répertoire s'ouvre afin que je puisse choisir une image. Celle-ci est automatiquement insérée et dimensionnée. Le nom de la photo est automatiquement collé dans la cellule G15 et ainsi de suite. Le code actuel permet d'insérer les images dans les cellules G6 et O6 mais il faudrait que ce code s'applique également aux cellules W6, AE6...DO6, G18...DO18 jusqu'à DO570 soit 720 possibilités d'insertions d'images. Je ne peux donc pas reproduire le code 720 fois et l'appliquer aux cellules où seront insérées les images car il y aura un message d'erreur de compilation, procédure trop grande.

J'ai donc besoin de votre aide pour modifier le code afin de tenir compte de toutes les possibilités.

Je vous remercie à l'avance pour votre précieuse collaboration.

Sincères salutations,

Renaud22

 

[Regueiro]

Re : Exécution d'un code VBA appliqué à des cellules sélectionnées

Bonsoir
Code à adapter

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i As Byte
For i = 7 To 100 Step 8
 For Each c In Target
    If c.Column = i Then
     Application.GetOpenFilename
     
     End If
   Next c
   Next i
   
End Sub

A+

 

[mapomme]

Re : Exécution d'un code VBA appliqué à des cellules sélectionnées

Bonsoir Renaud22, Regueiro,

Un essai dans le fichier joint. On utilise une procédure paramétrée avec la cellule cible comme paramètre: Sub InsererImage(xrg As Range).

Le code est dans le module de la feuille "Moteur":

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lig&, col&
  lig = Target.Row: col = Target.Column
  If lig > Range("ee570").Row Or col > Range("ee570").Column Then Exit Sub
  If (col - Range("g6").Column) Mod (Range("o6").Column - Range("g6").Column) <> 0 Then Exit Sub
  If (lig - Range("g6").Row) Mod (Range("g18").Row - Range("g6").Row) <> 0 Then Exit Sub
  cancel = True
  InsererImage Target(1, 1)
End Sub

Sub InsererImage(xrg As Range)
' Macro & instructions pour coller une photo et le nom de celle-ci
Dim zz As String, g As String, xx As String
Dim myPicture As Object
Dim d As Byte, aux

On Error GoTo 1
Application.DisplayAlerts = False
aa = Application.GetOpenFilename
If aa = False Then Exit Sub

zz = Dir(aa)
d = Len(zz)
Do Until g = "."
    g = Mid(zz, d, 1)
    d = d - 1
Loop
xx = Left(zz, Len(zz) - (Len(zz) - d))
xrg.Offset(1) = xx

Set myPicture = ActiveSheet.Pictures.Insert(aa)
myPicture.OnAction = "Agrandissement_Image"
myPicture.ShapeRange.AlternativeText = "zoom"
With myPicture.ShapeRange
    .Left = xrg.Left
    .Top = xrg.Top
    .Fill.Visible = msoTrue
    .Fill.Solid
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Fill.Transparency = 0#
    .Line.Weight = 0.75
    .Line.DashStyle = msoLineSolid
    .Line.Style = msoLineSingle
    .Line.Transparency = 0#
    .Line.Visible = msoTrue
    .Line.ForeColor.SchemeColor = 64
    .Line.BackColor.RGB = RGB(255, 255, 255)
    .LockAspectRatio = msoTrue
    .Height = xrg.Resize(9).Height
    If .Width > xrg.Resize(, 2).Width Then .Width = xrg.Resize(, 2).Width
    .Rotation = 0#
End With
Application.DisplayAlerts = True
End
1
On Error GoTo 0
Application.DisplayAlerts = True
End Sub

 

[Renaud22]

Re : Exécution d'un code VBA appliqué à des cellules sélectionnées

Bonjour "mapomme" et "Regueiro",

Merci pour vos réponses.

Merci "mapomme" pour avoir modifié le code VBA et avoir parfaitement adapté celui-ci en fonction de mes besoins. Votre aide est fortement appréciée.

Tout fonctionne à merveille.

Sincères salutations,

Renaud22