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

Renaud22

XLDnaute Junior
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
 

Pièces jointes

  • Base de données - 26-02-14_V1.zip
    189.4 KB · Affichages: 16

Regueiro

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

Bonsoir
Code à adapter
Code:
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

XLDnaute Barbatruc
Supporter XLD
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":
VB:
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
 

Pièces jointes

  • Renaud22.zip
    355 KB · Affichages: 30

Renaud22

XLDnaute Junior
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
 

Statistiques des forums

Discussions
314 450
Messages
2 109 726
Membres
110 552
dernier inscrit
jasson