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

[Flav7638]

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

 

[Cousinhub]

Bonjour,
Et bienvenue sur Xld.
Comme c'est ton premier post, je n'ai pas retrouvé la discussion citée.
Pourrais-tu y faire un lien?

 

[Flav7638]

https://excel-downloads.com/threads...-de-samedi-ou-dimanche-dans-cellule.20078273/
Pardon, je croyais avoir mis le lien

 

[piga25]

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

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]

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
Et passer de 16 000 lignes à 5 710 lignes

Merci de ton retour

 

[Flav7638]

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

 

[AtTheOne]

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 :

voilà le code :

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

 

[Flav7638]

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 :

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 !

 

[AtTheOne]

Re

j'ai des feuilles où j'ai une 5ème colonne avec le taux d'humidité

C'est sur toutes les feuilles ou seulement certaines ?
Peux-tu transmettre un exemple ?
A bientôt