Affecter une macro a plusieurs cellules

Résolu/Fermé

moshojo Messages postés 21 Date d'inscription mardi 2 août 2011 Statut Membre Dernière intervention 19 novembre 2013 - Modifié par moshojo le 8/08/2011 à 13:44
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

A voir également:

Affecter une macro a plusieurs cellules
Formule excel pour additionner plusieurs cellules - Guide
Macro word - Guide
Macro logiciel - Télécharger - Organisation
Aller à la ligne dans une cellule excel - Guide
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur

2 réponses

Réponse 1 / 2

melanie1324 Messages postés 1505 Date d'inscription vendredi 25 mai 2007 Statut Membre Dernière intervention 31 janvier 2018 154
8 août 2011 à 16:24

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
8 août 2011 à 16:32

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
8 août 2011 à 17:58

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 mardi 2 août 2011 Statut Membre Dernière intervention 19 novembre 2013
9 août 2011 à 15:09

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
9 août 2011 à 20:01

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

Cellules en surbrillance selon une TextBox

Discussions similaires

Newsletters