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

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...