Suppression de données inf a un certaine date ou vides par macro VBA

Version imprimable

1 pièce(s) jointe(s)

Bonjour à Tous,

j'ai un fichier de données que vous trouverez en pieces jointes.
le but cherché est de supprimer par macro les lignes dont la date en colonne D est vide ou inferieure à la date d'aujourd'hui
pour cela j'ai écrit ceci en VBA :
le filtre personalisé :date vide est bien pris en compte mais pas le deuxième critère (inf à la date d'aujourd'hui).
j'ai essayé d'inverser les deux criteres, le problème est le même. il ne prends en compte que le critère 2

Quelqu'un peut il m'aider à résoudre ce problème
Code:

1 2 3 4 5 6 7 8 9 Sub SupprDonnéesInutiles() ActiveSheet.Cells.AutoFilter Field:=4, Criteria1:="<" & Date, Operator:=xlOr, Criteria2:="=" For Each c In [_filterdatabase].Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible) LigFiltrée = c.Row: Exit For Next c ActiveSheet.Rows("" & LigFiltrée & ":" & LigFiltrée & "").Select ActiveSheet.Range(Selection, Selection.End(xlDown)).Delete Shift:=xlUp ActiveSheet.Cells.AutoFilter Field:=4 End Sub

bonsoir
je suis débutant en VBA et j'ai lu sur ce forum que c'est mieux d'utiliser les filtres élaborés
mais à mon niveau de débutant je travaille avec ça :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub SupprDonnéesInutiles()
Dim plage As Range
Dim DernLigne As Long
DernLigne = Sheets("feuil1").Range("A" & Rows.Count).End(xlUp).Row
Set plage = Sheets("feuil1").Range("D2:D" & DernLigne)
With Sheets("feuil1")
For Each cell In plage
If cell.Value < Date or cell.Value="" Then
cell.Select
Selection.EntireRow.Delete
   End If
   Next cell
   End With
End Sub

1 pièce(s) jointe(s)

Citation:

Envoyé par BENNASR

bonsoir
je suis débutant en VBA et j'ai lu sur ce forum que c'est mieux d'utiliser les filtres élaborés
mais à mon niveau de débutant je travaille ...

Quand tu supprimes des cellules dans une boucle, il faut toujours partir de la fin vers le début.
Par exemple :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Option Explicit
Sub SupprDonnéesInutiles()
Dim cel As Range
  Set cel = Worksheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(0, 3)
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Do While cel.Row > 1
    If cel.Value < Date Or cel.Value = "" Then
      Set cel = cel.Offset(-1)
      cel.Offset(1).EntireRow.Delete
    Else
      Set cel = cel.Offset(-1)
    End If
  Loop
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Re,

Ou bien, avec un filtre élaboré :

Code:

1
2
3
4
5
6
7
8
9
10
11
Sub SupprDonnéesFiltrées()
Dim rngDonnees As Range
Dim rngCritere As Range
 
  Set rngDonnees = Worksheets("Feuil1").Range("a1").CurrentRegion
  Set rngCritere = Worksheets("Critères").Range("a1").CurrentRegion
  rngDonnees.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCritere
  rngDonnees.Offset(1).SpecialCells(xlCellTypeVisible).Delete (xlUp)
  If Worksheets("Feuil1").FilterMode Then Worksheets("Feuil1").ShowAllData
 
End Sub

Ton fichier avec l'exemple précédent et avec un filtre élaboré ci-dessus (au choix) :

Bonjour,

Je fais une petite suggestion: c'est vraiment dommage de basser par un filtre (très bien) pour avoir une boucle super lente après sous la forme

Code:

1
2
3
4
5
6
7
Do While cel.Row > 1
    If cel.Value < Date Or cel.Value = "" Then
      Set cel = cel.Offset(-1)
      cel.Offset(1).EntireRow.Delete
    Else
      Set cel = cel.Offset(-1)
    End If

=> Donc l'approche peut être bien plus rapide:

1. Vous filtrez (en une ou deux fois)
2. Vous supprimer le réultat du filtre en passant par les .SpecialCells(xlCellTypeVisible), en une passe

Voir exemple ci-dessous, à adapter (ou faire une fonction)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub Delete_DateRecords()
 
Dim Wsh As Worksheet
Dim SrcRng As Range, DataRng As Range
 
'Initialisation
    Set Wsh = ActiveSheet 'A adapter
 
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = True   'A adapter
    End With
    Set SrcRng = Wsh.Range("A1").CurrentRegion   'à adapter
 
' On filtre sur les valeurs dupliquées
    SrcRng.AutoFilter Field:=4, Criteria1:="TRUE"     '4 = Columne filtrée (à adapter)
 
' On ne prend que les data affichées après le filtre
    Set DataRng = SrcRng.Offset(1, 0).Resize(SrcRng.Rows.Count - 2, SrcRng.Columns.Count).SpecialCells(xlCellTypeVisible) 'On ne garde que la partie résultat du filtre, en enlevant le header
    Debug.Print DataRng.Address
 
 
' Et on efface
    DataRng.Rows.Delete
    SrcRng.AutoFilter Field:=4      ' On reset les filtres
 
End Sub

19/01/2017, 18h30
Philippe Tulliez

Bonjour,
Un exemple : Supprimer des lignes suivant critères avec la méthode AdvancedFilter

Merci pour ta solution. je voulais absolument passer par le filtre personnalisé. Ta solution est beaucoup plus simple. Tu as raison
merci encore
Citation:
Envoyé par Patrice740
Quand tu supprimes des cellules dans une boucle, il faut toujours partir de la fin vers le début.
Par exemple :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 Option Explicit Sub SupprDonnéesInutiles() Dim cel As Range Set cel = Worksheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(0, 3) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Do While cel.Row > 1 If cel.Value < Date Or cel.Value = "" Then Set cel = cel.Offset(-1) cel.Offset(1).EntireRow.Delete Else Set cel = cel.Offset(-1) End If Loop Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

20/01/2017, 09h07
unparia

Bonjour vinc_bilb
Avec une réserve en ce qui concerne l'aptitude de Specialcells de "construire" nativement une plage discontinue dont le nombre d'aires dépasse la moitié de la limite d'un integer.
Mais le cas est rare (un très grand nombre de cellules concernées et réparties de telle manière que le nombre d'aires est alors élevé).