Bonjour,
Je post une question sur ce fil (pour comprendre)
--------------------------------------------------------------------------------------------------------
Auteur: fabrice
Date: 01-12-02 14:07
Bonjour,
Vous m'aviez fais passer une macro mais il semble qu'il y ai un peit probleme.
Les cellules me se grise pas et ne sont pas supprimées par la suite.
Des fois elles sagrise et se supprime mais uniquement pour le mois de janvier. Si je mets un autre mois, ca ne marche pas.
Pourriez vous m'aider à résoudre le problème.
Merci de votre réponses.
FAb
--------------------------------------------------------------------------------------------------------
REPONSE du service après-vente !!! (Robert as-tu un SAV au fait !!!) (lol)
========
Dans ce code je précisais la plage à analyser à dimension fixe :
Set Maplage = Worksheets(1).Range("A1:E50") ne connaissant pas ton tableau....
Là je procède autrement car je demande à VBA de chercher la dernière cellule pleine au bas de la colonne "H"........
Set Maplage = Worksheets("Feuil1").Range("A2", [H65536].End(xlUp))
NB à changer si la dernière colonne n'est pas H.... Exemple ton tableau va de la colonne A à la Colonne X, le code sera :
Set Maplage = Worksheets("Feuil1").Range("A2", [Z65536].End(xlUp))
(PS je pars de "A2" pour ne pas toucher aux "headings" de tes colonnes, mais on peut partir d'ailleurs)...
VOICI LE CODE (Avec les variables déclarées en prime !
Option Explicit
Sub ChercherEtDetruire()
Dim RECHERCHE As String
Dim c As Range
Dim Maplage As Range
Dim FirstAddress As String
Dim Alerte As String
Dim Cell As Range
RECHERCHE = InputBox("Votre recherche ? (attention aux Majuscules/Minuscules) ")
If RECHERCHE = "" Then Exit Sub
Set Maplage = Worksheets("Feuil1").Range("A2", [H65536].End(xlUp))
With Maplage
Set c = .Find(RECHERCHE, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.Interior.Pattern = xlPatternGray50
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Alerte = MsgBox("Toutes les cellules grisées vont être supprimmées", vbYesNo, "Warning")
If Alerte = vbYes Then
For Each Cell In Maplage
If Cell.Interior.Pattern = xlPatternGray50 Then
Cell.EntireRow.Delete
End If
Next
Else
Maplage.Select
Selection.Interior.ColorIndex = xlNone
End If
Range("a1").Select
Set Maplage = Nothing
End Sub
NB :
===
Il y a toujours le "EntireRow.Delete" qui pose un problème en cas de cellules contenant la valeur recherchée sur des lignes adjacentes...En fait il vaudrait mieux utiliser : EntireRow.ClearContents mais celà implique un "Sort" (tri) à la fin de l'instruction... Si çà peut te convenir ? Attention Fabrice tu perdras l'ordre dans lequel les données ont été saisies...
AUTRE METHODE :
Option Explicit
Sub ChercherEtEffacer()
Dim RECHERCHE As String
Dim c As Range
Dim Maplage As Range
Dim FirstAddress As String
Dim Alerte As String
Dim Cell As Range
RECHERCHE = InputBox("Votre recherche ? (attention aux Majuscules/Minuscules) ")
If RECHERCHE = "" Then Exit Sub
Set Maplage = Worksheets("Feuil1").Range("A2", [H65536].End(xlUp))
With Maplage
Set c = .Find(RECHERCHE, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.Interior.Pattern = xlPatternGray50
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Alerte = MsgBox("Toutes les cellules grisées vont être supprimmées", vbYesNo, "Warning")
If Alerte = vbYes Then
For Each Cell In Maplage
If Cell.Interior.Pattern = xlPatternGray50 Then
With Cell
.EntireRow.ClearContents
.Interior.ColorIndex = xlNone
End With
End If
Next
Else
Maplage.Select
Selection.Interior.ColorIndex = xlNone
End If
Maplage.Select
Selection.Sort Key1:=Range("A2"), Header:=xlGuess
Range("a1").Select
Set Maplage = Nothing
End Sub
ATTENTION : Cette seconde Méthode utilise un "Sort" (tri) sur la colonne A (à changer si tu dois avoir un tri ailleurs....)
Voilà cette fois ci tu devrais ne plus avoir de problème de couverture de ta zone Fabrice...
Bon travail & Bon Dimanche
@+Thierry
