classer des lignes par dates dans une autre feuille

[pascal21]

bonjour à tous
feuille 1, j'ai un tableau avec des immat de véhicules et les dates de contrôles techniques de chacun de véhicules (sur env. 100 lignes)
comment faire en cliquant sur le bouton que les lignes contenant des dates colorées en orange (MFC, échéance proche - 30 jours) se placent dans la feuille 2 mais par ordre croissant
ensuite même chose pour les lignes avec cellules colorées (voir MFC) en rouge mais cette fois dans la feuill 3
si la copie pouvait se faire avec uniquement les valeurs et les couleurs de cellules, tant mieux!!!!! (sans les formules)
merci de votre aide

 

[job75]

Re : classer des lignes par dates dans une autre feuille

Bonjour pascal21, le forum,

Je ne me suis occupé que de la MFC de couleur orange, car je n'ai pas compris la logique de la MFC de couleur rouge (mais ça ne devrait pas être bien différent).

La macro dans le code de Feuil1 :

Private Sub CommandButton1_Click()
Dim n As Byte
n = Application.CountIf(Columns("B"), "Alerte!")
With Sheets("Feuil2")
  .Cells.Clear
  Cells.Copy .Cells
  .Rows("3:65536").Sort Key1:=.Range("I3"), Order1:=xlAscending, Header:=xlNo
  .Rows("3:" & n) = .Rows("3:" & n).Value
  .Rows(n + 3 & ":65536").Delete
End With
End Sub

A+

 

[job75]

Re : classer des lignes par dates dans une autre feuille

Re,

Il y avait une imprécision dans le tri, j'ai édité le post précédent.

A+

 

[Compte Supprimé 979]

Re : classer des lignes par dates dans une autre feuille

Salut Pascal21, Job75

Une autre façon de faire

Private Sub CommandButton1_Click()
  Dim DerLig As Long, DerLigD As Long, Lig
  Dim ShtD As Worksheet
  ' Définir la feuille de destination
  Set ShtD = Sheets("Feuil2")
  ' Effacer la feuille 2 avant la copie
  DerLigD = ShtD.Range("C" & Rows.Count).End(xlUp).Row
  If DerLigD > 2 Then
    ShtD.Range("A3:L" & DerLigD + 1).Clear
  End If
  ' Avec la feuille source
  With Sheets("Feuil1")
    DerLig = .Range("C" & Rows.Count).End(xlUp).Row
    For Lig = 3 To DerLig
      If .Range("B" & Lig).Value = "Alerte!" Then
        ' Trouver la dernière ligne utilisée
        DerLigD = ShtD.Range("C" & Rows.Count).End(xlUp).Row
        ' Copier la ligne en alerte orange
        .Range("A" & Lig & ":L" & Lig).Copy
        ' Coller uniquement la valeur et la couleur
        ShtD.Range("A" & DerLigD + 1).PasteSpecial Paste:=xlPasteValues
        ShtD.Range("A" & DerLigD + 1).PasteSpecial Paste:=xlPasteFormats
      End If
    Next Lig
  End With
  ' Trier les lignes de la feuille 2
  With ShtD
    DerLigD = ShtD.Range("A" & Rows.Count).End(xlUp).Row
    .Activate
    .Range("A3:L" & DerLigD).Sort Key1:=.Range("I3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  End With
End Sub

 

[pascal21]

Re : classer des lignes par dates dans une autre feuille

bonjour job
merci pour le coup de main
mais si ça fonctionne bien dans le fichier que j'ai mis en piece jointe ça ne fonctionne pas correctement dans le fichier définitif
ça ne recopie en fait que 7 lignes et encore pas celles qui ont une alerte
mais les 7 premieres ligne de la feuil1
mais j'ai pensé à une autre façon de procéder
ton code ne devrait recopier uniquement que les nouvelles alertes du "jour" sans effacer les anciennes lignes dans la feuille 2
les nouvelles alertes venant s'écrire à la suite des autres
car je mets à la main dans les colonnes ABà AE; des commentaires pour les RDV à prendre
je complique peut-être un peu le truc
merci

 

[job75]

Re : classer des lignes par dates dans une autre feuille

Re,

Salut Bruno content de te croiser, il y avait longtemps.

Effectivement Pascal, j'ai revu ma copie, et j'ai compris la MFC rouge (je n'avais pas compris à cause des couleurs de fond rouge...).

Donc voici pour les Feuil2 et Feuil3 :

Private Sub CommandButton1_Click()
Dim plage As Range, derlig As Long, lig As Long
Set plage = Intersect(Rows("3:65536"), UsedRange)
If plage Is Nothing Then Exit Sub
derlig = plage.Row + plage.Rows.Count - 1
With Sheets("Feuil2")
  .Cells.Clear
  Cells.Copy .Cells
Set plage = .Range(plage.Address)
plage.Sort Key1:=.Range("I3"), Order1:=xlAscending, Header:=xlNo
  plage = plage.Value
  For lig = derlig To 3 Step -1
    If .Cells(lig, "B") <> "Alerte!" Then .Rows(lig).Delete
  Next
End With
With Sheets("Feuil3")
  .Cells.Clear
  Cells.Copy .Cells
  Set plage = .Range(plage.Address)
  plage.Sort Key1:=.Range("I3"), Order1:=xlAscending, Header:=xlNo
  plage = plage.Value
  For lig = derlig To 3 Step -1
    If .Cells(lig, "A") <> "Alerte!" Then .Rows(lig).Delete
  Next
End With
End Sub

 

[job75]

Re : classer des lignes par dates dans une autre feuille

Re,

J'avais omis de prendre en compte les commentaires éventuels en colonnes AB:AE de Feuil2 et Feuil3.

Cette version en tient compte, en plus j'ai créé la macro Copie pour simplifier le code :

Dim plage As Range, derlig As Long 'mémorise les variables

Private Sub CommandButton1_Click()
Set plage = Intersect(Rows("3:65536"), UsedRange)
If plage Is Nothing Then Exit Sub
derlig = plage.Row + plage.Rows.Count - 1
Copie "Feuil2", 2
Copie "Feuil3", 1
End Sub

Sub Copie(F$, col As Byte)
Dim ligne As Long, plage1 As Range, lig As Long
With Sheets(F)
  ligne = .UsedRange.Row + .UsedRange.Rows.Count
  plage.EntireRow.Copy .Rows(ligne)
  Set plage1 = .Rows("3:" & ligne + derlig)
  For lig = ligne + derlig To 3 Step -1
    If .Cells(lig, col) <> "Alerte!" Then .Rows(lig).Delete 'seules les alertes sont conservées
  Next
  plage1.Sort Key1:=.Range("D3"), Header:=xlNo 'tri sur IMMAT
  For lig = ligne + derlig To 4 Step -1
    If .Cells(lig, "D") = .Cells(lig - 1, "D") Then .Rows(lig).Delete 'suppression des doublons, les commentaires éventuels en AB:AE sont sur la ligne précédente, et sont donc conservés
  Next
  plage1.Sort Key1:=.Range("I3"), Order1:=xlAscending, Header:=xlNo 'tri sur dates MINES
  plage1 = plage1.Value 'suppression des formules
End With
End Sub

A+

 

[job75]

Re : classer des lignes par dates dans une autre feuille

Bonsoir Pascal, le forum,

Avec ce code l'exécution est plus rapide :

Dim plage As Range 'mémorise la variable

Private Sub CommandButton1_Click()
Set plage = Intersect(Rows("3:65536"), UsedRange)
If plage Is Nothing Then Exit Sub
Copie "Feuil2", 2
Copie "Feuil3", 1
End Sub

Sub Copie(F$, col As Byte)
Dim ligne As Long, lig As Long, sup As Range
With Sheets(F)
  ligne = .UsedRange.Row + .UsedRange.Rows.Count
  plage.EntireRow.Copy .Rows(ligne)
  .UsedRange = .UsedRange.Value 'supprime les formules
  [COLOR="Red"].Rows("3:65536").Sort Key1:=.Columns(col), Order1:=xlDescending, Header:=xlNo 'tri sur la colonne des alertes
  lig = Application.CountIf(.Columns(col), "Alerte!") + 3 '1ère ligne sans alerte
  .Rows(lig & ":65536").Delete 'supprime les lignes sans alerte[/COLOR]
  .Rows("3:65536").Sort Key1:=.Columns("D"), Header:=xlNo 'tri sur IMMAT
  For lig = 4 To lig - 1
    If .Cells(lig, "D") = .Cells(lig - 1, "D") Then _
      [COLOR="Red"]Set sup = Union(.Rows(lig), IIf(sup Is Nothing, .Rows(lig), sup))[/COLOR] 'les commentaires éventuels en AB:AE sont sur la ligne précédente, et seront donc conservés
  Next
  If Not sup Is Nothing Then sup.Delete 'supprime les doublons
  .Rows("3:65536").Sort Key1:=.Columns("I"), Order1:=xlAscending, Header:=xlNo 'tri sur dates MINES
End With
End Sub

A+