Copier une cellule dans un autre onglet en fonction de la valeur d'une autre cellule

[LAPIN-53]

Bonjour,
J'aurais besoin d'aide pour la création d'une macro sur Excel. Je voudrais copier des cellules d'un onglet vers un autre si la valeur d'une autre cellule = Oui.
Ci-joint un fichier : dans l'onglet plan d'action des action sont répertoriées dans la colonne E avec la notion de fait marquant dans la colonne F.
Dans le cas où il est indiqué Oui dans la colonne F, je voudrais en cliquant sur un bouton, copier toutes les cellules de la colonne E pour lesquelles F = oui dans l'onglet Rapport.

Merci d'avance pour votre aide.

 

[Robert]

Bonjour Lelièvre, bonjour le forum,

Ce code fonctionnera bien si deux lignes vides uniquement séparent le point 1.1 du point 1.2...

Sub Macro1()
Dim P As Worksheet 'déclare la variable P (onglet Plan d'action)
Dim R As Worksheet 'déclare la variable R (onglet Rapport)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set P = Worksheets("Plan d'action") 'définit l'onglet P
Set R = Worksheets("Rapport") 'définit l'onglet R
TV = P.Range("A4").CurrentRegion 'définit le tableau des valeurs TV
J = 1 'initialise la variable J
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs (en partant de la seconde)
  If TV(I, 6) = "OUI" Then 'condition : si la donnée ligne I colonne 6 du tableau des valeurs TV vaut "OUI"
  ReDim Preserve TL(1 To J) 'redimensionne le tableau des lignes TL
  TL(J) = TV(I, 5) 'récupère l'action dans la ligne J de TL
  J = J + 1 'incrémente J
  End If 'fin de la condition
Next I 'prochaine ligne de la boucle
For I = 1 To J - 1 'boucle sur les J-1 lignes détectées
  R.Rows(7).Insert Shift:=xlDown 'insère une ligne sous la ligne 7
Next I 'prochaine ligne détectée de la boucle
R.Range("B7").Resize(UBound(TL), 1).Value = Application.Transpose(TL) 'renvoie dans B7 redimensionnée le tableau TL transposé
End Sub

 

[LAPIN-53]

Merci beaucoup, c'est génial, ça marche super
Juste un petit souci avec la police et la couleur mais je vais étudier le problème.