Affecter une macro a plusieurs cellules

Résolu
moshojo Messages postés 23 Statut Membre -  
 Paf -
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 Messages postés 1561 Statut Membre 156
     
    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
    0
  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é
    0
    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"
      0
    2. moshojo Messages postés 23 Statut Membre
       
      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
      0
    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
      0

Discussions similaires

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

27 réponses
Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

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

38 réponses