Retour à la FAQ

Ce code permet de rechercher un mot "x" dans un colonne "x"
et de copier ou détruire les lignes qui contiennent ce mot dans la colonne choisie vers un onglet
qui aura pour nom le mot choisi... P. Mac Kay

========================================

Option Explicit

Sub déplacer_ou_détruire() 'XL 2000
' P. Mac Kay 06/2001 avec l'aide de Frédéric Sigonneau
' P.Mac Kay with the great help from
' F. Sigonneau [frederic.sigonneau@wanadoo.fr]
' deletion or move rows that contents a "word"
' you a choice : the word, the column where to find this word and
' move or delete "entire" rows where the word is

' Déplacement ou destruction des lignes contenant une occurence demandée dans
'un onglet
' en choisissant le mot et la colonne où le trouver.
' la recherche du mot est *exacte*
' un onglet est crée dans lequel on retrouve toutes les lignes qui
'contiennent le mot choisi.
' Avec la préciseuse aide de Frederic Sigonneau que je remercie

Dim colonne As String, copie As String
Dim mot As String, copie_efface As String
Application.ScreenUpdating = False

' What word find ?
mot = InputBox("Quel mot faut il chercher ? ", "EFFACEMENT CONDITIONNEL DE LIGNES ")
If mot = "" Then Exit Sub

Do
' in column ( A or B or C etc...)
colonne = InputBox("Dans quelle colonne faut-il chercher le mot ?" & Chr(10) & "en lettres, pas de chiffre ")
Loop Until ColonneValide(colonne)
' n'autoriser que Effacer ou Copier

choix:
Do
' move or delete rows ? E = effacer = delete D = déplacer = Move rows
copie = InputBox("Voulez-vous Effacer ou Déplacer ?" _
& Chr(10) & "Taper E pour Effacer ou D pour Déplacer")
Loop Until UCase(copie) = "D" Or UCase(copie) = "E"

' appel de la procédure avec 3 paramètres
' le mot à rechercher, la colonne où il est censé se trouver,et le choix
' de déplacer ou effacer
Effacer mot, colonne, copie ' mot choisi, colonne choisie, déplacer ou
'Effacer
End Sub

Function ColonneValide(Col) As Boolean
' avec l'aide De Frédéric Sigonneau [frederic.sigonneau@wanadoo.fr]
Col = UCase(Col)
Select Case Len(Col)
Case 1
ColonneValide = Col Like "[A-Z]"
Case 2
ColonneValide = Left(Col, 1) Like "[A-I]" And Right(Col, 1) Like "[A-V]"
End Select
End Function

Sub Effacer(parametre, colo, del_copy)
' déclaration variables

' Dim rngDelete3 As Range ' emplacement provisoire avant effacement
Dim rng1 As Range
Dim rng3 As Range, s As String, le_parametre As Boolean, mname As String

Sheets(1).Select
' mémoriser la feuille 1

s = ActiveSheet.Name
With ActiveSheet
For Each rng3 In .Range(.Cells(1, colo), _
.Cells(.Rows.Count, colo).End(xlUp))

' comparaison du paramètre avec le contenu de la cellule
le_parametre = UCase(rng3.Value) Like UCase(parametre)
If le_parametre = True Then
If rngDelete3 Is Nothing Then ' si c'est vide (au premier
'passage)
Set rngDelete3 = rng3.EntireRow 'marquer la ligne pour la
'"poubelle"

Else
Set rngDelete3 = Union(rngDelete3, rng3) ' si déjà une ligne
'au moins , ajout de l 'actuelle
End If
End If
Next rng3 ' ligne suivante
End With

If rngDelete3 Is Nothing Then
Beep
' no line with the word
MsgBox ("Pas de ligne avec le mot " & parametre & Chr(10) & " dans la colonne " & colo)
Exit Sub

End If

If UCase(del_copy) = "D" Then ' on déplace
mname = parametre
' l'onglet portera le nom du mot à effacer
'MsgBox (mname)
On Error Resume Next
Worksheets.Add(after:=ActiveSheet).Name = mname
ActiveWindow.Zoom = 85
Sheets(mname).Select
Application.CutCopyMode = False
If Not rngDelete3 Is Nothing Then
Set rng1 = Sheets(mname).Range("A1")
rngDelete3.EntireRow.Copy rng1
rngDelete3.EntireRow.Delete
End If

Sheets(mname).Range("A1").Select
Else ' effacer
If Not rngDelete3 Is Nothing Then
rngDelete3.EntireRow.Delete
End If
End If
Sheets(s).Select
Range("A2").Activate
End Sub

[top]