XL 2019 Suppression multiple de lignes - Macro

Bastien43

XLDnaute Occasionnel
Bonjour,

J'ai un fichier "releve compteur" : la première colonne contient la date+heure et la deuxième le volume relevé.

Je cherche à conserver uniquement les lignes de relevé qui ont lieu toutes les 15 minutes avec leur volume correspondant. Par exemple :

09/03/2021 00:00:001250000
09/03/2021 00:15:001250010
09/03/2021 00:30:001250011
09/03/2021 00:45:001250050
09/03/2021 01:00:001250055
09/03/2021 01:15:001250070
09/03/2021 01:30:001250090
09/03/2021 01:45:001250092
09/03/2021 02:00:001250100

Je souhaite supprimer les lignes non nécessaires. J'ai plusieurs fichiers de ce type et les relevés compteurs ne sont pas identiques. L'espacement entre les dates peut varier.

La date de relevé peut être aussi sur une journée ou bien s'étendre sur plusieurs jours (1 semaine).

Comment faire une macro ? Des idées svp ? ou bien une solution ? La tâche manuelle est fastidieuse.

Je vous remercie.
Cordialement
Bastien
 

Pièces jointes

  • Releve Compteur.xls
    194 KB · Affichages: 18
Solution
Ce que je voulais dire, en copiant de nouvelles données dans la première feuille, cela ne donne pas un résultat fiable à 100% dans la 2e
C'est fiable à 100%, Excel ne fait pas dans le bricolage.
par contre, pas moyen de le faire avec une macro ? sans 2e feuille ? ce serait plus simple.
On peut bien sûr ne pas utiliser une 2ème feuille et c'est très facile, mais alors les données sources seront perdues, c'est un inconvénient.

Placez cette macro dans un module standard (Module1) :
VB:
Sub Une_feuille()
Dim tablo, i&, dat$, min%, n&
tablo = [A1].CurrentRegion.Resize(, 2) 'feuille active
For i = 1 To UBound(tablo)
    dat = Format(tablo(i, 1), "mm/dd/yyyy hh:mm") 'date au format US
    min = Val(Right(dat, 2))
    If...

Etoto

XLDnaute Accro
Bonjour,

J'ai un fichier "releve compteur" : la première colonne contient la date+heure et la deuxième le volume relevé.

Je cherche à conserver uniquement les lignes de relevé qui ont lieu toutes les 15 minutes avec leur volume correspondant. Par exemple :

09/03/2021 00:00:001250000
09/03/2021 00:15:001250010
09/03/2021 00:30:001250011
09/03/2021 00:45:001250050
09/03/2021 01:00:001250055
09/03/2021 01:15:001250070
09/03/2021 01:30:001250090
09/03/2021 01:45:001250092
09/03/2021 02:00:001250100

Je souhaite supprimer les lignes non nécessaires. J'ai plusieurs fichiers de ce type et les relevés compteurs ne sont pas identiques. L'espacement entre les dates peut varier.

La date de relevé peut être aussi sur une journée ou bien s'étendre sur plusieurs jours (1 semaine).

Comment faire une macro ? Des idées svp ? ou bien une solution ? La tâche manuelle est fastidieuse.

Je vous remercie.
Cordialement
Bastien
Bonjour,

Créer une macro aussi est fastidieux mais tu le fais qu'une fois ;) .
 

soan

XLDnaute Barbatruc
Bonjour Bastien, Etoto,

* le 1er fichier est un .xls (215 Ko)
* le 2ème fichier est le .xls converti en .xlsm (52 Ko)
➯ gain : -163 Ko (-75,81 %)

à part cette différence de taille, les 2 fichiers sont identiques.



sur la feuille "CPT_LANDE_RAGOT", fais Ctrl e ➯ c'est fait ! 😊

le nombre de lignes est passé de 2 244 à ... 216 ! 🥳

donc y'a eu 2 028 lignes en moins ! 🤩



code VBA de Module1 :

VB:
Option Explicit: Option Base 1

Sub Essai()
  Dim n&: n = Cells(Rows.Count, 1).End(3).Row: If n = 1 Then Exit Sub
  Dim T1, T2, k As Byte, i&, j&
  n = n - 1: T1 = [A2].Resize(n, 2): ReDim T2(n, 2): j = 1
  Application.ScreenUpdating = 0: Range("A2:B" & n + 1) = Empty
  For i = 1 To n
    k = Minute(T1(i, 1)) Mod 15
    If k = 0 Then
      T2(j, 1) = CDate(T1(i, 1)): T2(j, 2) = T1(i, 2): j = j + 1
    End If
  Next i
  [A2].Resize(n, 2) = T2
End Sub

soan
 

Pièces jointes

  • Releve Compteur v1.xls
    215 KB · Affichages: 3
  • Releve Compteur v1.xlsm
    51.8 KB · Affichages: 4
Dernière édition:

Bastien43

XLDnaute Occasionnel
Bonjour,

Merci beaucoup, cela me facilite le travail.

Une question : comment éviter les doublons ou données triples svp ? Est-ce possible d'avoir qu'une seule ligne pour le même quart de temps ?

03/09/2021 08:00 50072
03/09/2021 08:15 50091
03/09/2021 08:15 50091
03/09/2021 08:30 50111
03/09/2021 08:30 50111
03/09/2021 08:45 50131
03/09/2021 09:00 50151
03/09/2021 09:15 50171
03/09/2021 09:30 50189
03/09/2021 10:00 50189
03/09/2021 10:15 50189
03/09/2021 10:15 50189
03/09/2021 10:30 50189

Je vous remercie pour votre aide. Cela me facilite beaucoup la lecture des données

Cordialement,
Bastien
 

soan

XLDnaute Barbatruc
Bonsoir Bastien,

relis mon post #3 car j'ai modifié le texte ; télécharge de nouveau les 2 fichiers, car j'ai corrigé quelques bugs qui étaient dans l'ancienne sub Essai() ; le code VBA qui était entre balises de code a été remplacé par le nouveau code VBA. (rappel : pour les 2 fichiers, c'est le même code VBA)

soan
 

soan

XLDnaute Barbatruc
Bonjour Bastien,

voici la 2ème version. :)

fais Ctrl e ➯ le nombre de lignes est passé de 2 244 à ... 47 ! 🥳

donc y'a eu 2 197 lignes en moins ! 🤩

VB:
Option Explicit: Option Base 1

Sub Essai()
  Dim n&: n = Cells(Rows.Count, 1).End(3).Row: If n = 1 Then Exit Sub
  Dim T1, T2, DRC As Date, CPT&, r As Byte, i&, j&, k&
  n = n - 1: T1 = [A2].Resize(n, 2): ReDim T2(n, 2): j = 1
  Application.ScreenUpdating = 0: Range("A2:B" & n + 1) = Empty
  For i = 1 To n
    DRC = CDate(T1(i, 1)): r = Minute(DRC) Mod 15
    If r = 0 Then
      CPT = T1(i, 2): If j > 1 Then k = j - 1: r = -(CPT = T2(k, 2))
      If r = 0 Then T2(j, 1) = DRC: T2(j, 2) = CPT: j = j + 1
    End If
  Next i
  [A2].Resize(n, 2) = T2
End Sub

soan
 

Pièces jointes

  • Releve Compteur v2.xlsm
    52.4 KB · Affichages: 11

Bastien43

XLDnaute Occasionnel
Bonjour,

merci beaucoup pour votre aide et la macro. C'est super. Juste une dernière demande svp. Est-il possible de garder tous les pas de temps de 15 min (même si le volume en face reste constant ?)

date 00:00:00 Volume
date 00:00:15 Volume
date 00:00:30 Volume
date 00:00:45 Volume
date 00:01:00 Volume
date 00:01:15 Volume
date 00:01:30 Volume
date 00:01:45 Volume
....

Il devrait y avoir 96 lignes à la fin pour une journée.

Si il y a 2 jours cela donnerait 96 x 2 = 192 lignes, etc.

Est-ce possible ? cela me permet ensuite de calculer le débit sur ce pas de temps de 15 min

Je vous remercie pour votre aide et votre temps.

Cordialement
Bastien
 

job75

XLDnaute Barbatruc
Bonjour Bastien43, Etoto, soan,
Une question : comment éviter les doublons ou données triples svp ? Est-ce possible d'avoir qu'une seule ligne pour le même quart de temps ?
Ton dernier fichier @soan ne tient pas compte de cette contrainte.

Et il vaut mieux mettre les résultats dans une 2ème feuille contenant cette macro évènementielle :
VB:
Private Sub Worksheet_Activate()
Dim tablo, i&, dat$, min%, n&
tablo = Feuil1.[A1].CurrentRegion.Resize(, 2) 'CodeName à adapter
For i = 1 To UBound(tablo)
    dat = Format(tablo(i, 1), "mm/dd/yyyy hh:mm") 'date au format US
    min = Val(Right(dat, 2))
    If min Mod 15 = 0 Then n = n + 1: tablo(n, 1) = dat: tablo(n, 2) = tablo(i, 2)
Next
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
[A1].Resize(n, 2) = tablo '1ère cellule de destination, à adapter
[A1].Resize(n, 2).RemoveDuplicates 1, Header:=xlYes 'supprime les doublons en colonne A (ce n'est pas obligatoire)
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Elle se déclenche quand on active la feuille, voyez le fichier joint.

A+
 

Pièces jointes

  • Releve Compteur(1).xls
    204 KB · Affichages: 5

Bastien43

XLDnaute Occasionnel
Bonjour,

Merci, autre façon de faire. C'est super.
Comment cela fonctionne si j'ai un fichier excel nouveau ? Avec une macro, je l'exécute rapidement avec le raccourci mais ici je devrais ajouter une nouvelle feuille dans le nouveau fichier ? ca marche automatiquement ?
Car j'ai une trentaine de fichier à traiter...
Je vous remercie pour votre aide

Bastien
 

job75

XLDnaute Barbatruc
Oui il faudra une 2ème feuille avec son code pour chaque fichier, elle se créera rapidement par copie.

Notez que pour supprimer les doublons uniquement si les valeurs en A et B sont les mêmes :
VB:
[A1].Resize(n, 2).RemoveDuplicates Array(1, 2), Header:=xlYes 'supprime les doublons des colonnes A et B (ce n'est pas obligatoire)
Fichier (2).
 

Pièces jointes

  • Releve Compteur(2).xls
    204.5 KB · Affichages: 4

job75

XLDnaute Barbatruc
Faites l'effort de comprendre la différence qu'il y a entre la suppression des doublons du fichier (1) post #9 et la suppression des doublons du fichier (2) post #11, c'est pourtant assez évident et en plus j'ai expliqué...
 

Bastien43

XLDnaute Occasionnel
ok merci je ne suis pas un expert.
Ce que je voulais dire, en copiant de nouvelles données dans la première feuille, cela ne donne pas un résultat fiable à 100% dans la 2e
par contre, pas moyen de le faire avec une macro ? sans 2e feuille ? ce serait plus simple.
Merci
 
Dernière édition:

job75

XLDnaute Barbatruc
Ce que je voulais dire, en copiant de nouvelles données dans la première feuille, cela ne donne pas un résultat fiable à 100% dans la 2e
C'est fiable à 100%, Excel ne fait pas dans le bricolage.
par contre, pas moyen de le faire avec une macro ? sans 2e feuille ? ce serait plus simple.
On peut bien sûr ne pas utiliser une 2ème feuille et c'est très facile, mais alors les données sources seront perdues, c'est un inconvénient.

Placez cette macro dans un module standard (Module1) :
VB:
Sub Une_feuille()
Dim tablo, i&, dat$, min%, n&
tablo = [A1].CurrentRegion.Resize(, 2) 'feuille active
For i = 1 To UBound(tablo)
    dat = Format(tablo(i, 1), "mm/dd/yyyy hh:mm") 'date au format US
    min = Val(Right(dat, 2))
    If min Mod 15 = 0 Then n = n + 1: tablo(n, 1) = dat: tablo(n, 2) = tablo(i, 2)
Next
'---restitution---
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Columns("A:B").ClearContents 'RAZ
[A1].Resize(n, 2) = tablo '1ère cellule de destination, à adapter
[A1].Resize(n, 2).RemoveDuplicates Array(1, 2), Header:=xlYes 'supprime les doublons en colonnes A et B (ce n'est pas obligatoire)
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
End Sub
C'est toujours la feuille active qui sera traitée.
 

Statistiques des forums

Discussions
293 048
Messages
1 928 125
Membres
183 853
dernier inscrit
ali1987