Affecter une macro a plusieurs cellules

Résolu

moshojo Messages postés 21 Date d'inscription Statut Membre Dernière intervention -
Paf - 9 août 2011 à 20:01

Bonjour à tous!

Je travaille sur un tableau de quatre colonnes. La premiere contient des noms de produits, dans les trois autres colonne je souhaite afficher des images correspondants aux dangers des produits (trois dangers maximums)

J'ai écrit le code pour la ligne 4. et j'aimerai répéter la macro jusque la ligne 24 mais je ne sais pas comment faire à par tout copier coller et remplacer le numéro de la ligne

Merci davance si vous avez une solution,

Charlotte

j'ai utilisé le code suivant :

Sub DANGER()

Range("D4").Select 'Case ou mettre le pictogramme

Test = Range("D4").Value 'Celulle à tester

Select Case Test

Case "Xn"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xn.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "Xi"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xi.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "C"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\C.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case Else

End Select

Range("F4").Select 'Case ou mettre le pictogramme

Test = Range("F4").Value 'Celulle à tester

Select Case Test

Case "Xn"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xn.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "Xi"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xi.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "C"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\C.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case Else

End Select

Range("H4").Select 'Case ou mettre le pictogramme

Test = Range("H4").Value 'Celulle à tester

Select Case Test

Case "Xn"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xn.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "Xi"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xi.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "C"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\C.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case Else

End Select

Exit Sub

End Sub

Afficher la suite

A voir également:

Affecter une macro a plusieurs cellules
Formule excel pour additionner plusieurs cellules - Guide
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Verrouiller cellules excel - Guide
Jitbit macro recorder - Télécharger - Confidentialité
Aller à la ligne dans une cellule excel - Guide

2 réponses

Réponse 1 / 2

melanie1324 Messages postés 1504 Date d'inscription Statut Membre Dernière intervention 155

bonjour,

Sub DANGER()

for i = 4 to 24

cells(i,4).Select 'Case ou mettre le pictogramme

Test = cells(i,4).Value 'Celulle à tester

Select Case Test

Case "Xn"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xn.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "Xi"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xi.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "C"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\C.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case Else

End Select

cells(i,6).Select 'Case ou mettre le pictogramme

Test = cells(i,6).Value 'Celulle à tester

Select Case Test

Case "Xn"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xn.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "Xi"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xi.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "C"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\C.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case Else

End Select

cells(i,8).Select 'Case ou mettre le pictogramme

Test = cells(i,8).Value 'Celulle à tester

Select Case Test

Case "Xn"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xn.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "Xi"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\Xi.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case "C"

ActiveSheet.Pictures.Insert("I:\LOGO DANGER\C.png").Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With

Case Else

End Select

next i

End Sub

Réponse 2 / 2

Paf

bonjour
dans la mesure où on fait la même action pour chaque ligne chaque colonne et chaque "danger" (si je n'ai pas lu trop vite), on peut simplifier:

Sub DANGER() 
For i = 4 To 24 ' pour les lignes 4 à 24
  For j = 4 To 8 Step 2 'pour les colonnes 4,6 et 8 soit : D, F et H
    Cells(i, j).Select 'Case ou mettre le pictogramme
    MonImage = "I:\LOGO DANGER\" & Cells(i, j).Value & ".xls"

    ActiveSheet.Pictures.Insert(MonImage).Select ' insertion
    With Selection.ShapeRange
        .LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
        .Top = ActiveCell.Top ' haut de la cellule
        .Left = ActiveCell.Left ' gauche de la cellule
        .Height = ActiveCell.RowHeight ' hauteur de la cellule
        .Width = ActiveCell.Width ' largeur de la cellule
    End With
    With Selection
        .PrintObject = True ' l'objet est imprimé en même temps que le document
        .Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
    End With
  Next j
Next i

End Sub

Bonne suite

PS: pas testé

Paf

oups une erreur!
ce n'est pas

MonImage = "I:\LOGO DANGER\" & Cells(i, j).Value & ".xls"

mais

MonImage = "I:\LOGO DANGER\" & Cells(i, j).Value & ".png"

moshojo Messages postés 21 Date d'inscription Statut Membre Dernière intervention

Salut !!

J'ai testé la solution de Mélanie et elle marche super bien ! merci beaucoup
Pour la solution de Paf, ça marche mais la macro plante dès qu'il y a une cellule vide

Merci encore pour votre aide

Charlotte

Paf

bonsoir
pour éviter que ça plante, on peut tester si la cellule n'est pas vide, il n'y a que deux lignes à rajouter :

For i = 4 To 24 ' pour les lignes 4 à 24
  For j = 4 To 8 Step 2 'pour les colonnes 4,6 et 8 soit : D, F et H
   If Cells(i, j).value < > "" Then
    Cells(i, j).Select 'Case ou mettre le pictogramme
 ...
...
    End With
   End If
  Next j
Next i

Bonne suite

Discussions similaires

recup couleur de cellule sans macro

Transformer un chiffre en lettres dans excel sans macro

additionner nombres dans cellules avec texte

Votre réponse

Discussions similaires