Microsoft 365 Copier une ligne s'il y a une cellule en "ROUGE" dans celle-ci

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
A

ange45

XLDnaute Nouveau
Bonjour,

Je suis entrain de faire un tableau pour le suivi des formations.
Sur mon onglet "Tableau de bord" j'ai fais 2 mises en forme conditionnelle. La date en ROUGE si elle dépasse la date d'aujourdhui et en ORANGE pour me prévenir 3 mois avant.


Maintenant je voudrais sur un autre onglet nommée "Synthèses" ravoir le même tableau, mai en ayant seulement les lignes si les dates sont en ROUGE ou ORANGE.

Pour mes 2 onglets mes tableaux commences en C15 et fini en K15.

Apparemment c'est possible avec du VBA. mais je n'ai aucune notion malheureusement.

Est ce que quelqu'un peu m'aider svp?
 

Pièces jointes

Trier par date Trier par votes
vgendron à dit:
le meme mais avec collage special valeur (pour éviter de copier les formules)
et avec des commentaires dans le code

pour voir le code:
ouvrir l'éditeur vba: Alt+F11
dans l'explorateur à gauche, double clic sur le module 1 du projet
et à droite, le code apparait.
Cliquez pour agrandir...

Super, c'est bien ce que je souhaite.

Partcontre si je rajoute une donnée sur le tableau "TABLEAU DE BORD" et que je reclique sur le bouton mes date presente sur mon onglet "Syntheses" sont en doublon😥

Je vais tester et regarder le code

merci encore
 
Dernière édition:
Vote positif 0 Vote négatif
PS: j'ai réduit volontairement les tableaux au strict minimum
un des intérêts des tableaux structurés, c'est qu'il suffit d'ajouter des donner juste sous le tablo pour que celui ci s'adapte automatiquement en taille
je leur ai donné des noms plus parlant et plus pratique pour s'y retrouver


en plus, avoir des tableaux à rallonge, vide, ca augmente inutilement la taille des fichiers
 
Vote positif 0 Vote négatif
vgendron à dit:
PS: j'ai réduit volontairement les tableaux au strict minimum
un des intérêts des tableaux structurés, c'est qu'il suffit d'ajouter des donner juste sous le tablo pour que celui ci s'adapte automatiquement en taille
je leur ai donné des noms plus parlant et plus pratique pour s'y retrouver


en plus, avoir des tableaux à rallonge, vide, ca augmente inutilement la taille des fichiers
Cliquez pour agrandir...
J'ai regardé le code VBA, c'est wouuaaa

Pour être franche j'y comprend rien du tout😅

Savez vous comment faire pour eviter les doublons si on reclique sur le bouton "generer synthese"
 
Vote positif 0 Vote négatif
Bonjour le fil, bonjour le forum,

Grillé grave par Vgendron qui a été rapide sur ce coup !... Tans pis j'envoie quand même ma proposition puisque j'y ai passé pas mal de temps...
En pièce jointe ton fichier modifié avec le code ci-dessous :
VB: 
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TS As ListObject 'déclare la variable TS (Tableau Source)
Dim TD As ListObject 'déclare la variable TD (Tableau Destination)
Dim I As Integer 'déclare la variable I (Incrément)
Dim R As Range 'déclare la variable R (Recherche)
Dim LI As Integer 'déclare la variable LI (LIgne)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Worksheets("Tableau de bord") 'définit l'onglet OS
Set OD = Worksheets("Synthèses") 'définit l'onglet OD
Set TS = OS.ListObjects("Tableau6") 'définit le tableau TS
Set TD = OD.ListObjects("Tableau4") 'définit le tableau TD
If TD.ListRows.Count > 0 Then TD.DataBodyRange.Delete 'efface les données de TD si TD contient au moins une ligne
For I = 1 To TS.ListRows.Count 'boucle sur toutes les lignes I de TS
    If TS.DataBodyRange(I, 8) <> "" Then 'condition 1 : si la valeur en colonne 8 n'est pas vide
        'condition 2 : reprend les deux conditions de la MFC,si une des condition est vérifiée
        If CDate(TS.DataBodyRange(I, 8)) < Date Or DateSerial(Year(CDate(TS.DataBodyRange(I, 8))), Month(CDate(TS.DataBodyRange(I, 8))) - 3, Day(CDate(TS.DataBodyRange(I, 8)))) < Date Then
            Set R = TD.ListColumns(1).Range.Find("") 'définit la recherche R (recherche du vide dans la colonne 1 de TD)
            If R Is Nothing Or TD.ListRows.Count = 0 Then 'condition 3 : si aucune occurrence n'est trouvée ou si TD ne contient aucune ligne
                TD.ListRows.Add 'ajoute une ligne à TD
                LI = TD.ListRows.Count 'définit la ligne LI (la dernière ligne de TD)
            Else 'sinon (au moins une occurrence est trouvée)
                LI = R.Row - TD.HeaderRowRange.Row + 1 'définit la ligne LI (ligne de la première occurence trouvée moins la ligne des en-têtes de TD plus une)
            End If 'fin de la condition 3
            TS.ListRows(I).Range.Copy 'copie la ligne I de TS
            TD.DataBodyRange(LI, 1).PasteSpecial (xlValues) 'colle les valeurs dans les données de TD ligne LI colonne 1
            'récupère le nom et prénom (parfois non renseigné en colonne 1 de TS)
            TD.DataBodyRange(LI, 1) = IIf(TS.DataBodyRange(I, 1) <> "", TS.DataBodyRange(I, 1).Value, TS.DataBodyRange(I, 1).End(xlUp).Value)
            'récupère la matricule (parfois non renseignée en colonne 2 de TS)
            TD.DataBodyRange(LI, 2) = IIf(TS.DataBodyRange(I, 2) <> "", TS.DataBodyRange(I, 2).Value, TS.DataBodyRange(I, 1).End(xlUp).Offset(0, 1).Value)
        End If 'fin de la condition 2
    End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle
Application.CutCopyMode = False 'suprimme le clignotement lié au copier/coller
OD.Activate 'active l'onglet OD
OD.Range("C14").Select 'sélectionne la cellule C14 de OD
End Sub
Le fichier :
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour balfourier, vgendron, Robert,

Voici une solution très simple qui utilise le filtre avancé.

Voyez le fichier joint et cette macro dans le code de la feuille "Synthèses" :
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Range("C16:J" & Rows.Count).Delete xlUp
With Sheets("Tableau de bord").ListObjects(1).Range
    On Error Resume Next 'si aucune SpecialCell
    Set r = .Columns(1).Resize(, 2).SpecialCells(xlCellTypeBlanks)
    r = "=R[-1]C" 'remplit les cellules vides avec la valeur au-dessus
    .Cells(2, 10) = "=(J16<>"""")*((J16<TODAY())+(J16<EDATE(TODAY(),3)))" 'critère
    .AdvancedFilter xlFilterCopy, .Cells(1, 10).Resize(2), [C15:J15] 'filtre avancé copié
    .Cells(2, 10) = ""
    r = ""
End With
End Sub
Elle se déclenche automatiquement quand on active la feuille.

Nota : il est inutile et même nuisible que le tableau des résultats soit un tableau structuré.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Avec ce fichier (2) la MFC sur la colonne J est copiée :
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Range("C16:J" & Rows.Count).Delete xlUp
With Sheets("Tableau de bord").ListObjects(1).Range
    On Error Resume Next 'si aucune SpecialCell
    Set r = .Columns(1).Resize(, 2).SpecialCells(xlCellTypeBlanks)
    r = "=R[-1]C" 'remplit les cellules vides avec la valeur au-dessus
    .Cells(2, 10) = "=(J16<>"""")*((J16<TODAY())+(J16<EDATE(TODAY(),3)))" 'critère
    .AdvancedFilter xlFilterCopy, .Cells(1, 10).Resize(2), [C15:J15] 'filtre avancé copié
    .Cells(2, 10) = ""
    r = ""
    '---copie la MFC---
    If [J16] = "" Then Exit Sub
    Set r = ActiveCell
    .Cells(2, 8).Copy
    Range("J16", Range("J" & Rows.Count).End(xlUp)).PasteSpecial xlPasteFormats 'collage spécial Formats
    Application.CutCopyMode = 0
    r.Select
End With
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Bonsoir job75, le fil,

job75 à dit:
Nota : il est inutile et même nuisible que le tableau des résultats soit un tableau structuré.
Cliquez pour agrandir...

incroyable ! 😲 c'est la première fois que je lis un post d'un des adeptes des tableaux structurés qui informe qu'un tableau structuré est déconseillé ! (dans le cas présent)

donc ça rejoint mon opinion : un tableau structuré n'est pas forcément la panacée, et ça n'est pas à utiliser systématiquement ! merci, job75 ! 😊 😇 🥳​

soan
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Question Question
Colorier une cellule en rouge quand une échéance arrive a son terme
2
Réponses
23
Affichages
7 K
aktos
A
Retour