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

Phil69970 à dit:

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

Cliquez pour agrandir...

AtTheOne à dit:

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

Cliquez pour agrandir...

Flav7638 à dit:

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

Cliquez pour agrandir...