Suppression multiple de lignes selon une référence
Bonjour,
Je dispose de nombreux fichiers excel du même format que les 3 pièces jointes. Tous les fichiers sont dans le même dossier
Sur chaque excel, il y a colonne A : les dates et heures ; colonne B : les mesure de débits.
Je souhaite faire une macro pour :
- sélectionner une date de la colonne A en rendant la cellule active : exemple 28/06/2021 - hh/mm/ss (quelque soit l'heure)
- supprimer toutes les autres lignes n'étant pas du 28/06/2021, mais garder la première ligne d'en-tête n°1
- bien garder la même disposition, le même format (1 cellule) et donc la même heure pour chaque ligne retenue à la date du 28/06/2021
- le faire pour tous les fichiers excel du dossier (même date)
Les noms des fichiers et des feuilles sont différents aussi (il y a 300 fichiers...)
Comment faire ? une idée svp ?
Je vous remercie pour votre aide
Cordialement
Bastien
Bonjour,
Voici un premier essai avec cette macro qui se déclenche au double clic sur la feuille permettant l'exécution de ce code. Il faudra donc mettre ce code (la première macro au moins) dans le module de cette feuille.
Private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)
cancel = true
if isdate(target.value) and target.column = 1 then
if msgbox("Lancer la suppression ?", vbyesno) = vbyes then
Parcourir Clng(Int(target.value2))
end if
end if
end sub
Sub Parcourir(lngDate as long)
dim ws as worksheet
with thisworkbook
for each ws in .worksheets
Supprimer ws, lngDate
next ws
sfilename$ = dir(.path & "\*.xls*")
do while sfilename <> ""
if sfilename <> .name then
with workbooks.open(.path & "\" & sfilename)
for each ws in .worksheets
Supprimer ws, lngDate
next ws
.close true
end with
end if
sfilename = dir
loop
end with
end sub
Sub Supprimer(Feuille as worksheet, LngDate as long)
with Feuille
dl = .cells(.rows.count, 1).end(xlup).row
dc = .cells(1, .columns.count).end(xltoleft).column
t = .cells(1, 1).resize(dl, dc).value2
for i = 2 to ubound(t)
if int(t(i, 1)) = lngDate then
n = n + 1
for k = lbound(t, 2) to ubound(t, 2)
t(n, k) = t(i, k)
next k
end if
next i
with .cells(2, 1)
.clearcontents
if n > 0 then .resize(n, dc).value2 = t
end with
end with
end subOn considère que les fichiers excel sont tous fermés, excepté celui qui exécute la macro. La macro agit sur chaque feuille de chaque classeur y compris l'exécutant et ne teste que la colonne 1.
On suppose également qu'il n'y a que des valeurs. Si ce n'était pas le cas, il faudrait passer par une autre méthode, un peu plus chronophage.
Faites des essais avec un échantillon réduit car 300 fichiers, ça commence à faire beaucoup et toute modification par macro est irréversible.
Cdlt,
Bonjour,
Merci pour votre réponse et votre aide. J'ai mis à jour mon fichier avec la macro. Cependant à l'exécution du double clic sur la date, soit la cellule active devient la dernière du fichier, soit je peux saisir et taper dans la cellule. "Lancer la suppression ?" ne s'affiche pas.
Comment faire svp ?
Sinon puis écrire la date 28/06/2021 dans une autre cellule de la feuille et faire référence à cette date si c'est plus simple ?
Merci pour votre aide
Cordialement
Bastien
Bonjour,
Si Excel rend la dernière cellule active, c'est parce que vous avez raté votre double-clic (clic sur la bordure). Sinon, j'ai oublié de préciser que le code considère les dates en colonne 1. S'il y a une date en colonne 1, la macro s'exécute sinon, normalement, vous ne pouvez pas rentrer dans la cellule.
Il faut donc bien coller ce code dans le module de la feuille sur laquelle vous comptez double-cliquer.
Cdlt,
Re,
Je ne peux pas tester à votre place, n'ayant pas accès à vos dossiers.
Il faut marquer un point d'arrêt sur la ligne cancel = true (en cliquant sur la petite marge juste à gauche de l'éditeur). Il faut double-cliquer sur une des dates de la colonne 1. Ensuite, il faut exécuter la suite du code au pas à pas en utilisant la touche F8. Vous pourrez voir ce qui se passe dans le code.
Cdlt,
Salut Bastien,
Salut 3GB,
je planche là-dessus depuis hier en pestant mes grands Dieux de n'arriver à rien alors que le code me semblait tenir la route...
Est-ce vraiment une interprétation de ma part ou il y a quelque part une incompatibilité entre VBA 2019 et les fichiers .XLS de Bastien ?
Toujours est-il qu'en les convertissant en .XLSX, tout fonctionne comme désiré !!
Donc, Bastien, ! Attention ! , prière de tester ce qui suit sur une COPIE de ton répertoire de travail car comme l'a très bien dit 3GB
- Le fichier joint, qui contient la macro, doit être enregistré dans le même répertoire que les fichiers à traiter :
- Un clic sur le bouton démarre la macro :
* invitation à encoder la date à conserver ;
* elle ouvre les fichiers .XLS* rencontrés ;
* si celui-ci est un .XLS, elle le convertit de force en .XLSX et supprime l'ancien ;
* elle teste si une date se trouve en [A2], traite le fichier, le sauve et le ferme.
Comme dirait un collègue avant de se lancer dans le vide : GERONIMOOOOO !
Private Sub cmdOK_Click()
'
Dim sWkb As Workbook, rCelA As Range, rCelB As Range, sDate$, sPath$, sFileA$, sFileB$
'
Do
sDate = Application.InputBox("Quelle date voulez-vous conserver ?", "Correction", Format(Date, "dd/mm/yyyy"), , , , , 2)
Loop Until IsDate(sDate) Or sDate = "Faux"
If sDate = "Faux" Then Exit Sub
'
sPath = ThisWorkbook.Path
sFileA = Dir(sPath & "\" & "*.xls*")
'
On Error Resume Next
Application.ScreenUpdating = False
'
Do While Len(sFileA) > 0
sFileA = Dir()
Set sWkb = Workbooks.Open(sFileA)
If Split(sWkb.Name, ".")(1) = "xls" Then _
sFileB = Split(sWkb.Name, ".")(0) & ".xlsx": _
sWkb.SaveAs Filename:=sFileB, FileFormat:=xlOpenXMLWorkbook: _
Kill sPath & "\" & sFileA: _
Set sWkb = Workbooks.Open(sFileB)
If IsDate(sWkb.Sheets(1).[A2]) Then
With sWkb.Sheets(1)
.[A2].CurrentRegion.Sort key1:=.[A2], order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
Set rCelA = .Columns(1).Find(what:=sDate, lookat:=xlPart, LookIn:=xlValues, searchdirection:=xlNext)
Set rCelB = .Columns(1).Find(what:=sDate, lookat:=xlPart, LookIn:=xlValues, searchdirection:=xlPrevious)
'
If Not rCelA Is Nothing And Not rCelB Is Nothing Then
If rCelB.Row < .Range("A" & Rows.Count).End(xlUp).Row Then .Rows(rCelB.Row + 1 & ":" & .Range("A" & Rows.Count).End(xlUp).Row).Delete shift:=xlUp
If rCelA.Row > 2 Then .Rows(2 & ":" & rCelA.Row - 1).Delete shift:=xlUp
If rCelA.Row = 2 And rCelB.Row < .Range("A" & Rows.Count).End(xlUp).Row Then .Rows(rCelB.Row + 1 & ":" & .Range("A" & Rows.Count).End(xlUp).Row).Delete shift:=xlUp
End If
End With
End If
sWkb.Save
sWkb.Close False
Loop
'
Application.ScreenUpdating = True
On Error GoTo 0
'
End Sub
A+
Bonjour,
Merci pour vos réponses. Je me penche sur le double clic et constater peut être l'incompatibilité, je vais installer une autre version d'excel sur mon 2e PC. Je vais faire le pas à pas. Merci 3GB pour votre aide.
Merci curulis57 cela fonctionne aussi et me donne une option supplémentaire. Merci beaucoup, cela m'aide énormément.
Cordialement
Bonjour Bastien, Salut Curulis,
En ce qui concerne mon code, je viens de m'apercevoir qu'il avait été inséré dans un module standard... Il faut bien le coller dans le module de la feuille contenant les dates en colonne 1, à savoir Q_IMPORT sur votre image. Je doute donc qu'il s'agisse d'une incompatibilité.
Cdlt,
Bonsoir,
Merci pour votre retour, je suis en train de tester. effectivement je me suis trompé de module. J'ai ensuite une erreur : "incompatibilité de type" à cette ligne
Parcourir CLng(Int(target.Value2))
Je regarde pour débloquer le problème
Merci pour votre aide.
Bonsoir,
Pouvez-vous essayer ce nouveau code :
Private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)
cancel = true
if isdate(target.value) and target.column = 1 then
if msgbox("Lancer la suppression ?", vbyesno) = vbyes then
Parcourir Int(target.value2)
end if
end if
end sub
Sub Parcourir(dDate as double)
dim ws as worksheet
with thisworkbook
for each ws in .worksheets
Supprimer ws, dDate
next ws
sfilename$ = dir(.path & "\*.xls*")
do while sfilename <> ""
if sfilename <> .name then
with workbooks.open(.path & "\" & sfilename)
for each ws in .worksheets
Supprimer ws, dDate
next ws
.close true
end with
end if
sfilename = dir
loop
end with
end sub
Sub Supprimer(Feuille as worksheet, dDate as double)
with Feuille
dl = .cells(.rows.count, 1).end(xlup).row
dc = .cells(1, .columns.count).end(xltoleft).column
t = .cells(1, 1).resize(dl, dc).value2
for i = 2 to ubound(t)
if int(t(i, 1)) = dDate then
n = n + 1
for k = lbound(t, 2) to ubound(t, 2)
t(n, k) = t(i, k)
next k
end if
next i
with .cells(2, 1)
.clearcontents
if n > 0 then .resize(n, dc).value2 = t
end with
end with
end subCdlt,
Bonsoir,
Merci pour votre retour. Le message box s'affiche mais ensuite j'ai encore le problème d'incompatibilité. Peut être est ce excel 2019.
Merci pour votre aide. Sinon je m'adapte et prendrai la macro avec la saisie de la date.
Cordialement
Bastien
Bonjour,
Non, ce n'est pas un problème de version. Je n'ai pas vu les fichiers donc je ne sais pas vraiment ce que contient la colonne 1.
Je dirais que soit il faut changer le type dans le code, soit les dates en colonne 1 sont au format texte ce qui crée l'incompatibilité...
Voici un essai avec ce code (temporaire pour test) :
Private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)
cancel = true
if isdate(target.value) and target.column = 1 then
msgbox typename(target.value2)
'if msgbox("Lancer la suppression ?", vbyesno) = vbyes then
' Parcourir Int(target.value2)
'end if
end if
end subOui, sinon, l'idée de Curulis avec l'inputbox n'est pas mauvaise et serait une bonne alternative.
Edit : Voici un nouvel essai si la colonne 1 contient bien des valeurs textuelles :
Private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)
cancel = true
if isdate(target.value) and target.column = 1 then
if msgbox("Lancer la suppression ?", vbyesno) = vbyes then
Parcourir cdate(target.value2)
end if
end if
end sub
Sub Parcourir(dDate as Date)
dim ws as worksheet
with thisworkbook
for each ws in .worksheets
Conserver ws, dDate
next ws
sfilename$ = dir(.path & "\*.xls*")
do while sfilename <> ""
if sfilename <> .name then
with workbooks.open(.path & "\" & sfilename)
for each ws in .worksheets
Conserver ws, dDate
next ws
.close true
end with
end if
sfilename = dir
loop
end with
end sub
Sub Conserver(Feuille as worksheet, dDate as Date)
with Feuille
dl = .cells(.rows.count, 1).end(xlup).row
dc = .cells(1, .columns.count).end(xltoleft).column
t = .cells(1, 1).resize(dl, dc).value2
for i = 2 to ubound(t)
if int(cdate(t(i, 1))) = int(dDate) then
n = n + 1
for k = lbound(t, 2) to ubound(t, 2)
t(n, k) = t(i, k)
next k
end if
next i
with .cells(2, 1)
.resize(dl - 1, dc).clearcontents
if n > 0 then .resize(n, dc).value2 = t
end with
end with
end subCdlt,
Bonjour,
Merci 3GB je vais tester
Cordialement
Bastien
Bonjour,
Merci 3GB je viens de tester, cela fonctionne. Cependant les dates sont dans un ordre décroissant, cela ne les efface pas/
Aussi serait-il possible de lancer cette macro depuis un fichier Excel qui est dans un dossier amont ?
J'ai ajusté la macro (voir fichiers joints). Cependant, vous pourrez voir, les dates sont dans un ordre décroissant.
Curulis57, la macro a tendance à supprimer tous les fichiers du dossier lors de l'exécution ? serait-ce du au format de la date ?
Cordialement
Bastien
Salut Bastien,
Salut 3GB,
la macro ne supprime que les anciens fichiers .XLS qu'elle a pris soin de sauver auparavant sous le format .XLSX !
Avec les quelques fichiers que tu nous a fournis, c'est ainsi que ça se passe.
De quels fichiers (supprimés) parles-tu ? Peux-tu nous envoyer un fichier-exemple comprenant les fichiers à traiter (Q1, Q2...) et ces autres fichiers ?
A+
Bonjour,
Merci pour votre réponse rapide.
Le fichiers sont par exemple joint en pièce jointes.
Dans mon message précédent, il y a un fichier test-macro.zip avec l'objectif final. Je cherche à appliquer cette macro à plusieurs dossier qui contient plusieurs fichiers.
Salut Bastien, Salut Curulis,
En ce qui concerne la macro, j'ai oublié de retailler la plage avant d'en effacer le contenu. Je viens de modifier le code, ça devrait être mieux.
Sinon, oui, il est possible et préférable d'exécuter cette macro depuis un fichier dédié qui n'a pas la même structure que les autres. Il faut préciser un peu le besoin car le double-clic ne serait probablement plus une bonne idée.
Cdlt,
Bonjour,
Merci pour la correction, cela fonctionne. C'est top. J'aime les 2 approches.
J'ai essayé d'adapter votre macro avec la boite de dialogue. Voici le résultat en fichier joint (Module 1). J'ai une incompatibilité de type à cette étape :
For i = 2 To UBound(t)
Comment faire svp ? Quel est le problème ?
Je vous remercie pour aide.