Affecter une macro a plusieurs cellules

Résolu
moshojo -  
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

2 réponses

  1. melanie1324
    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
    1. 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é
      1. 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"
      2.  moshojo Auteur
        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
      3. 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

    Excel : afficher toutes les lignes et colonnes masquées
    livlarsen

    27 réponses
    Reactiver la fusion des cellules, tableau exc
    chector10

    38 réponses
    recup couleur de cellule sans macro
    magouero

    7 réponses