Microsoft 365 VBA - Basculer des lignes d'onglet en onglet selon un critère

Y

yanus

XLDnaute Nouveau
Bonjour,

Je me permets de vous solliciter pour une petite difficulté, je suis dans une impasse pour le travail.

La demande est simple sur le papier mais je coince.

J'ai un fichier avec 3 feuilles "Suivi", "Renvoi" et "terminé".

Je commence par remplir mes lignes dans l'onglet "suivi", puis à partir du moment où une date figure dans la colonne H, je souhaiterais que toute la ligne bascule dans l'onglet "Renvoi" en grisant les colonnes B,C,D, mais si la colonne K est remplie, je souhaiterais que la ligne revienne à sa place initiale dans l'onglet "suivi".

Ensuite je voudrais que les lignes de l'onglet "renvoi" bascule dans l'onglet "Terminé" lorsque le mot "FIN" apparait dans la colonne Q.

Je ne sais pas si mes indications sont claires, je vous joins le fichier exemple.

Je vous remercie vivement par avance.
 

Pièces jointes

  • Classeur Inst.xlsx
    43.8 KB · Affichages: 5
Trier par date Trier par votes
Y

yanus

XLDnaute Nouveau
Je me permets de relancer mon petit sujet.

Suite aux macros, il m'est impossible de faire fonctionner les mises en formes conditionnelles que je souhaitais mettre en place, pourtant simple....

Je voudrais que dans l'onglet suivi, la ligne se mette en rouge lorsque "DP" figure dans la colonne "F". (et que ce soit le cas pour les nouvelles lignes qui s'ajouteront dans le tableau)

Et dans l'onglet "renvoi", j'aimerai griser les colonnes B, C et D, (également pour le nouvelles lignes qui s'ajouteront) mais la mise en forme du tableau ne fonctionne pas, est-ce pareil chez vous ?

Je vous joins le fichier.
 

Pièces jointes

  • Classeur Inst (2).xlsm
    30.1 KB · Affichages: 3
Vote positif 0 Vote négatif
AtTheOne

AtTheOne

XLDnaute Accro
Supporter XLD
Bonjour à toutes & à tous, bonjour @yanus
Ici la tortue 🐢 ou l'escargot 🐌 , bref le pas rapide !
Je joins quand même ma production en tenant compte de la MFC demandée au post 16 (cellules rouges police blanche si [DP/CJ/TA] = "DP") , les colonnes B, C ,D de l'onglet Renvoi étant systématiquement grises avec police blanche.
Enfin tout cela est blanc bonnet et bonnet blanc avec la proposition de @vgendron ...

Un petit plus : Les macros fonctionnent sur des modifications multiples dans les colonnes concernées. (ex : sélection de plusieurs cellules de la colonne [OSC 175] et validation de la date saisie par CTRL ENTREE)

Code Feuille Suivi
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Rng As Range, lgns$
    
     Set Rng = Intersect(Target, Me.[Tb_Suivi[OSC 175]])
     If Rng Is Nothing Then Exit Sub
     If Rng.Address <> Target.Address Then Exit Sub
     Application.EnableEvents = False
     For Each Zn In Rng.Areas: For Each c In Zn
          If IsDate(c) Then
               valeurs = Intersect(c.EntireRow, Me.[tb_Suivi])
               lgns = c.Row & ";" & lgns
               With sh_Renvoi.[tb_Renvoi]
                    If .Rows.Count = 1 And .Cells(1) = "" Then
                         .Resize(1, UBound(valeurs, 2)).Value = valeurs
                    Else
                         .Offset(.Rows.Count).Resize(1, UBound(valeurs, 2)).Value = valeurs
                    End If
               End With
          End If
     Next c: Next Zn
     If lgns <> "" Then
          LignesàDétruire = Split(lgns, ";")
          For i = 0 To UBound(LignesàDétruire) - 1
               Me.Rows(LignesàDétruire(i)).Delete
          Next i
     End If
     Application.EnableEvents = True
End Sub

Code Feuille Renvoi
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Rng1 As Range, Rng2 As Range, lgns$
    
     Set Rng1 = Intersect(Target, Me.[tb_Renvoi[AUTRES (RS)]])
     Set Rng2 = Intersect(Target, Me.[tb_Renvoi[TERMINE]])
     If Rng1 Is Nothing And Rng2 Is Nothing Then Exit Sub
    
     Application.EnableEvents = False
     If Not Rng1 Is Nothing Then
          If Rng1.Address = Target.Address Then
               For Each Zn In Rng1.Areas: For Each c In Zn
                    If c <> "" Then
                         valeurs = Intersect(c.EntireRow, Me.[tb_Renvoi]).Resize(, sh_Suivi.[tb_Suivi].Columns.Count - 1)
                         lgns = c.Row & ";" & lgns
                         With sh_Suivi.[tb_Suivi]
                              If .Rows.Count = 1 And .Cells(1) = "" Then
                                   .Resize(1, UBound(valeurs, 2)).Value = valeurs
                              Else
                                   .Offset(.Rows.Count).Resize(1, UBound(valeurs, 2)).Value = valeurs
                              End If
                         End With
                    End If
               Next c: Next Zn
          End If
     ElseIf Not Rng2 Is Nothing Then
          If Rng2.Address = Target.Address Then
               For Each Zn In Rng2.Areas: For Each c In Zn
                    If UCase(c) = "FIN" Then
                         valeurs = Intersect(c.EntireRow, Me.[tb_Renvoi])
                         lgns = c.Row & ";" & lgns
                         With sh_Terminé.[tb_Terminé]
                              If .Rows.Count = 1 And .Cells(1) = "" Then
                                   .Resize(1, UBound(valeurs, 2)).Value = valeurs
                              Else
                                   .Offset(.Rows.Count).Resize(1, UBound(valeurs, 2)).Value = valeurs
                              End If
                         End With
                    End If
               Next c: Next Zn
          End If
     End If
    
     If lgns <> "" Then
          LignesàDétruire = Split(lgns, ";")
          For i = 0 To UBound(LignesàDétruire) - 1
               Me.Rows(LignesàDétruire(i)).Delete
          Next i
     End If
    
     Application.EnableEvents = True
    
End Sub

Voir pièce jointe
A bientôt
 

Pièces jointes

  • Classeur Inst AtTheOne.xlsm
    31.8 KB · Affichages: 1
Vote positif 0 Vote négatif
Y

yanus

XLDnaute Nouveau
AtTheOne à dit:
Bonjour à toutes & à tous, bonjour @yanus
Ici la tortue 🐢 ou l'escargot 🐌 , bref le pas rapide !
Je joins quand même ma production en tenant compte de la MFC demandée au post 16 (cellules rouges police blanche si [DP/CJ/TA] = "DP") , les colonnes B, C ,D de l'onglet Renvoi étant systématiquement grises avec police blanche.
Enfin tout cela est blanc bonnet et bonnet blanc avec la proposition de @vgendron ...

Un petit plus : Les macros fonctionnent sur des modifications multiples dans les colonnes concernées. (ex : sélection de plusieurs cellules de la colonne [OSC 175] et validation de la date saisie par CTRL ENTREE)

Code Feuille Suivi
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Rng As Range, lgns$
   
     Set Rng = Intersect(Target, Me.[Tb_Suivi[OSC 175]])
     If Rng Is Nothing Then Exit Sub
     If Rng.Address <> Target.Address Then Exit Sub
     Application.EnableEvents = False
     For Each Zn In Rng.Areas: For Each c In Zn
          If IsDate(c) Then
               valeurs = Intersect(c.EntireRow, Me.[tb_Suivi])
               lgns = c.Row & ";" & lgns
               With sh_Renvoi.[tb_Renvoi]
                    If .Rows.Count = 1 And .Cells(1) = "" Then
                         .Resize(1, UBound(valeurs, 2)).Value = valeurs
                    Else
                         .Offset(.Rows.Count).Resize(1, UBound(valeurs, 2)).Value = valeurs
                    End If
               End With
          End If
     Next c: Next Zn
     If lgns <> "" Then
          LignesàDétruire = Split(lgns, ";")
          For i = 0 To UBound(LignesàDétruire) - 1
               Me.Rows(LignesàDétruire(i)).Delete
          Next i
     End If
     Application.EnableEvents = True
End Sub

Code Feuille Renvoi
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Rng1 As Range, Rng2 As Range, lgns$
   
     Set Rng1 = Intersect(Target, Me.[tb_Renvoi[AUTRES (RS)]])
     Set Rng2 = Intersect(Target, Me.[tb_Renvoi[TERMINE]])
     If Rng1 Is Nothing And Rng2 Is Nothing Then Exit Sub
   
     Application.EnableEvents = False
     If Not Rng1 Is Nothing Then
          If Rng1.Address = Target.Address Then
               For Each Zn In Rng1.Areas: For Each c In Zn
                    If c <> "" Then
                         valeurs = Intersect(c.EntireRow, Me.[tb_Renvoi]).Resize(, sh_Suivi.[tb_Suivi].Columns.Count - 1)
                         lgns = c.Row & ";" & lgns
                         With sh_Suivi.[tb_Suivi]
                              If .Rows.Count = 1 And .Cells(1) = "" Then
                                   .Resize(1, UBound(valeurs, 2)).Value = valeurs
                              Else
                                   .Offset(.Rows.Count).Resize(1, UBound(valeurs, 2)).Value = valeurs
                              End If
                         End With
                    End If
               Next c: Next Zn
          End If
     ElseIf Not Rng2 Is Nothing Then
          If Rng2.Address = Target.Address Then
               For Each Zn In Rng2.Areas: For Each c In Zn
                    If UCase(c) = "FIN" Then
                         valeurs = Intersect(c.EntireRow, Me.[tb_Renvoi])
                         lgns = c.Row & ";" & lgns
                         With sh_Terminé.[tb_Terminé]
                              If .Rows.Count = 1 And .Cells(1) = "" Then
                                   .Resize(1, UBound(valeurs, 2)).Value = valeurs
                              Else
                                   .Offset(.Rows.Count).Resize(1, UBound(valeurs, 2)).Value = valeurs
                              End If
                         End With
                    End If
               Next c: Next Zn
          End If
     End If
   
     If lgns <> "" Then
          LignesàDétruire = Split(lgns, ";")
          For i = 0 To UBound(LignesàDétruire) - 1
               Me.Rows(LignesàDétruire(i)).Delete
          Next i
     End If
   
     Application.EnableEvents = True
   
End Sub

Voir pièce jointe
A bientôt
Cliquez pour agrandir...
Bonjour @AtTheOne,

C'est tout simplement incroyable ce que tu m'as fait, c'est exactement tout ce que je recherchais.

Je ne sais pas comment te remercier.

Merci infiniment.
 
Vote positif 0 Vote négatif

Discussions similaires

O
  • Question
XL 2013 Recopier automatique des valeurs d'un onglet vers un autre onglet selon critère
Réponses
2
Affichages
409
olivieroma
O
T
  • Résolu(e)
Microsoft 365 Créer un onglet pour chaque thème contenant les titres en doublons associés à ce thème
2
Réponses
26
Affichages
602
Toucan72
T
Lisette
  • Question
Microsoft 365 VBA : copier / coller d'un onglet à l'autre en fonction d'une valeur
Réponses
8
Affichages
479
Lisette
Lisette
M
  • Question
XL 2019 Copier des lignes les unes a la suite des autres dans une autre feuille sous conditions et seulement certaines colonnes
Réponses
7
Affichages
541
MGH
M
M
  • Résolu(e)
Microsoft 365 Code pour tri avec critère
2
Réponses
18
Affichages
881
Marvin57
M
C
  • Résolu(e)
Copier/Masquer des lignes de couleur pour alimenter un tableau
Réponses
9
Affichages
396
vgendron
vgendron
L
  • Résolu(e)
Microsoft 365 VBA - Attribuer mise en forme en fonction de valeur cellule d'une liste
Réponses
14
Affichages
618
Laliepomm
L
M
  • Résolu(e)
Microsoft 365 Prendre les 10 1ère valeur d'une plage en fonction de 2 critères
2 3
Réponses
43
Affichages
2 K
merinos
merinos
M
  • Question
Microsoft 365 Construction d'un tableau selon 2 critères en VBA
Réponses
6
Affichages
406
merinos
merinos
G
  • Question
XL 2021 rassembler des données de plusieurs feuilles d'un classeur sur une nouvelle feuille du meme classeur selon un critère
Réponses
1
Affichages
363
Staple1600
Staple1600

Membres actuellement en ligne

17 membres et 321 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh