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

[yanus]

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.

 

[yanus]

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.

 

[vgendron]

Je ne comprend pas le problème..
il y a bien la MFC "rouge" lorsque DP en colonne F
dans la feuille renvoi.. pas de MFC.. donc.. pas de gris..

 

[AtTheOne]

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

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

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

 

[yanus]

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

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

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

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.