Microsoft 365 Supprimer des lignes en fonction de la date et de l'heure

Flav7638

XLDnaute Nouveau
Bonjour,

Grâce à votre aide j'ai déjà pu automatiser le traitement de mes fichiers de température / humidité... Je souhaiterai maintenant supprimer les lignes qui concernent les samedi et dimanche ainsi que les heures avant 7h00 et après 19h00 les jours de semaine. J'ai 28 feuilles de 8000 ou 16000 lignes !
J'ai essayé les solutions proposées par Phil69970 et Cousinhub dans cette discussion pour supprimer au moins les week-ends en inversant la condition mais cela ne fonctionne pas avec mon fichier, peut-être à cause des cellules fusionnées ?
Si quelqu'un veut bien m'aider à m'en sortir, je vous serai très reconnaissant 🙏🙏🙏
 

Pièces jointes

  • Test temp.xlsx
    498.3 KB · Affichages: 8
Solution
Bonjour à tous

Edit : @piga25
Si on fait ta macro en 1er on supprime les dates.
Je pense qu'il faut mieux d'abord défusionné et remplir les dates après la défusion et ensuite supprimer les heures et samedi/dimanche


@Flav7638
Pour info les cellules fusionnées c'est souvent une mauvaise idée

Je te propose ce fichier

Pour info sur mon PC la macro s’exécute en 29 secondes pour défusionné, mettre les dates sur chaque ligne, supprimé les lignes avant 7h00 et après 19h00 et supprimé les samedi/dimanche :oops: o_O
Et passer de 16 000 lignes à 5 710 lignes

1709671088605.png


Merci de ton retour

piga25

XLDnaute Barbatruc
Bonjour,
Pour commencer cela supprime les heures avant 7:00 et après 19:00.

VB:
Sub Sup()
For i = ActiveSheet().UsedRange.Rows.Count To 2 Step -1
    If Cells(i, 3) < 7 / 24 Then Rows(i).Delete
    If Cells(i, 3) > 19 / 24 Then Rows(i).Delete
Next
End Sub
 

Phil69970

XLDnaute Barbatruc
Bonjour à tous

Edit : @piga25
Si on fait ta macro en 1er on supprime les dates.
Je pense qu'il faut mieux d'abord défusionné et remplir les dates après la défusion et ensuite supprimer les heures et samedi/dimanche


@Flav7638
Pour info les cellules fusionnées c'est souvent une mauvaise idée

Je te propose ce fichier

Pour info sur mon PC la macro s’exécute en 29 secondes pour défusionné, mettre les dates sur chaque ligne, supprimé les lignes avant 7h00 et après 19h00 et supprimé les samedi/dimanche :oops: o_O
Et passer de 16 000 lignes à 5 710 lignes

1709671088605.png


Merci de ton retour
 

Pièces jointes

  • Sup lignes dates et heures V1.xlsm
    541.6 KB · Affichages: 6
Dernière édition:

Flav7638

XLDnaute Nouveau
Bonjour à tous

Edit : @piga25
Si on fait ta macro en 1er on supprime les dates.
Je pense qu'il faut mieux d'abord défusionné et remplir les dates après la défusion et ensuite supprimer les heures et samedi/dimanche


@Flav7638
Pour info les cellules fusionnées c'est souvent une mauvaise idée

Je te propose ce fichier

Pour info sur mon PC la macro s’exécute en 29 secondes pour défusionné, mettre les dates sur chaque ligne, supprimé les lignes avant 7h00 et après 19h00 et supprimé les samedi/dimanche :oops: o_O
Et passer de 16 000 lignes à 5 710 lignes

Regarde la pièce jointe 1192287

Merci de ton retour
Merci beaucoup @Phil69970 : ça marche au top !!! Bon, ça met environ 50 secondes sur mon PC de boulot mais il tourne avec un Intel Core 11th gen i5 à 2,4 GHz 🚣‍♂️ Après, pour 18 feuilles, ça va bien j'ai des résultats précis par rapport à ce que je cherche : nombre d'heures "ouvrables" d'inconfort, c'est à dire > 28°C.
Ce qui est dommage c'est que j'avais fait une macro pour fusionner car c'était utile pour faire des graphiques et je n'arrivais pas à défusionner. Je le saurais pour la prochaine fois.
Un très grand merci pour ta contribution !
 
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Bonjour à toutes et à tous, bonjour @Flav7638
Je te propose une macro qui respecte ta mise en page avec des cellules fusionnées (bien que ça ne soit pas idéal) et qui traite 28 feuilles de 16000 lignes en :
1709735846154.png

voilà le code :
VB:
Sub Nettoyer()
   
     Dim TbTmp(), TbRes(), Tmax As Double, Tmin As Double, Plg As Range, PlgRes As Range, Nbl As Double, d As Long
     début = Timer
     Tmax = 19 / 24
     Tmin = 7 / 24
     Application.ScreenUpdating = False
     NbSh = 0
     For Each WSh In ThisWorkbook.Worksheets

'Ligne à adapter en fonction du nom des feuilles à traiter (ici toutes les feuilles dont le nom commence par "Test ("
'====================================================================================================================
          If WSh.Name Like "Test (*" Then
'====================================================================================================================
               NbSh = NbSh + 1
               Set Plg = WSh.Evaluate("A7:A" & [A1048576].End(xlUp).Row).Resize(, 4)
               Tb = Plg.Value
               Plg.Columns(2).UnMerge
               Plg.ClearContents
             
               Nbl = UBound(Tb, 1)
               ReDim TbTmp(1 To 5, 1 To Nbl)
               d = CLng(Tb(1, 2))
               For i = 1 To Nbl
                    TbTmp(1, i) = Tb(i, 1)
                    If Not IsEmpty(Tb(i, 2)) Then d = CLng(Tb(i, 2))
                    TbTmp(2, i) = d
                    TbTmp(3, i) = Tb(i, 3)
                    TbTmp(4, i) = Tb(i, 4)
                    TbTmp(5, i) = Weekday(d, vbMonday)
               Next i
             
               Last = UBound(TbTmp, 2): k = 0
               For i = 1 To Last
                    If TbTmp(5, i) < 6 And TbTmp(3, i) > Tmin And TbTmp(3, i) < Tmax Then
                         k = k + 1
                         ReDim Preserve TbRes(1 To 4, 1 To k)
                         For j = 1 To 4
                              TbRes(j, k) = TbTmp(j, i)
                         Next
                    End If
               Next
               Set PlgRes = Plg.Resize(k, 4)
               PlgRes.Offset(0, 1).Resize(, 1).NumberFormat = "dd/mm/yyyy"
               PlgRes.Value = WorksheetFunction.Transpose(TbRes)
               d = TbRes(2, 1)
               i = 1
               Application.DisplayAlerts = False
             
               While i <= k
                    Déb = i: Fin = i
                    continuer = True
                    While continuer
                         i = i + 1
                         Fin = i
                         If i <= k Then
                              continuer = (TbRes(2, i) = d)
                         Else
                              continuer = False
                         End If
                    Wend
                    PlgRes.Offset(Déb - 1, 1).Resize(Fin - Déb, 1).Merge
                    If i <= k Then d = TbRes(2, i)
               Wend
               Application.DisplayAlerts = False
          End If
     Next WSh
     Application.ScreenUpdating = True

MsgBox NbSh & " feuilles en " & Timer - début & " secondes"

End Sub

Voir pièce jointe (avec 1 seule feuille pour cause de taille de fichier !)

A bientôt
 

Pièces jointes

  • Supprimer des lignes en fonction de la date et de l'heure.xlsm
    511.8 KB · Affichages: 2

Flav7638

XLDnaute Nouveau
Bonjour à toutes et à tous, bonjour @Flav7638
Je te propose une macro qui respecte ta mise en page avec des cellules fusionnées (bien que ça ne soit pas idéal) et qui traite 28 feuilles de 16000 lignes en :
Regarde la pièce jointe 1192330
voilà le code :
VB:
Sub Nettoyer()
  
     Dim TbTmp(), TbRes(), Tmax As Double, Tmin As Double, Plg As Range, PlgRes As Range, Nbl As Double, d As Long
     début = Timer
     Tmax = 19 / 24
     Tmin = 7 / 24
     Application.ScreenUpdating = False
     NbSh = 0
     For Each WSh In ThisWorkbook.Worksheets

'Ligne à adapter en fonction du nom des feuilles à traiter (ici toutes les feuilles dont le nom commence par "Test ("
'====================================================================================================================
          If WSh.Name Like "Test (*" Then
'====================================================================================================================
               NbSh = NbSh + 1
               Set Plg = WSh.Evaluate("A7:A" & [A1048576].End(xlUp).Row).Resize(, 4)
               Tb = Plg.Value
               Plg.Columns(2).UnMerge
               Plg.ClearContents
            
               Nbl = UBound(Tb, 1)
               ReDim TbTmp(1 To 5, 1 To Nbl)
               d = CLng(Tb(1, 2))
               For i = 1 To Nbl
                    TbTmp(1, i) = Tb(i, 1)
                    If Not IsEmpty(Tb(i, 2)) Then d = CLng(Tb(i, 2))
                    TbTmp(2, i) = d
                    TbTmp(3, i) = Tb(i, 3)
                    TbTmp(4, i) = Tb(i, 4)
                    TbTmp(5, i) = Weekday(d, vbMonday)
               Next i
            
               Last = UBound(TbTmp, 2): k = 0
               For i = 1 To Last
                    If TbTmp(5, i) < 6 And TbTmp(3, i) > Tmin And TbTmp(3, i) < Tmax Then
                         k = k + 1
                         ReDim Preserve TbRes(1 To 4, 1 To k)
                         For j = 1 To 4
                              TbRes(j, k) = TbTmp(j, i)
                         Next
                    End If
               Next
               Set PlgRes = Plg.Resize(k, 4)
               PlgRes.Offset(0, 1).Resize(, 1).NumberFormat = "dd/mm/yyyy"
               PlgRes.Value = WorksheetFunction.Transpose(TbRes)
               d = TbRes(2, 1)
               i = 1
               Application.DisplayAlerts = False
            
               While i <= k
                    Déb = i: Fin = i
                    continuer = True
                    While continuer
                         i = i + 1
                         Fin = i
                         If i <= k Then
                              continuer = (TbRes(2, i) = d)
                         Else
                              continuer = False
                         End If
                    Wend
                    PlgRes.Offset(Déb - 1, 1).Resize(Fin - Déb, 1).Merge
                    If i <= k Then d = TbRes(2, i)
               Wend
               Application.DisplayAlerts = False
          End If
     Next WSh
     Application.ScreenUpdating = True

MsgBox NbSh & " feuilles en " & Timer - début & " secondes"

End Sub

Voir pièce jointe (avec 1 seule feuille pour cause de taille de fichier !)

A bientôt
Bonjour et merci pour ta réponse ! C'est effectivement plus rapide et ça me garde la mise en page pour les graphiques. Par contre, j'ai des feuilles où j'ai une 5ème colonne avec le taux d'humidité et je n'arrive à modifier le paramètre qui permettrai de prendre en compte cette 5ème colonne 🤔 Je ne connais pas suffisamment VBA pour saisir l'intégralité de ton code !
 

Discussions similaires

Statistiques des forums

Discussions
312 935
Messages
2 093 740
Membres
105 805
dernier inscrit
belgacem.nahali