Une macro pour supprimer des lignes dans un message

Version imprimable

13/06/2012, 20h53
blade2a

Une macro pour supprimer des lignes dans un message

Bonjour a tous,
Je recherche a faire un petit outil pratique, en fait voila, je suis dans la marine, et j ai des messages a envoyer avec des informations sur les bateaux que l on croise, voici l exemple de message (je vous ne donne juste une partie car en général il y a plus de 300 bateaux) :

CTC/T00001/UNEQUATED-FAUST//TM/UNK//AG///NSP/00///////V2NA4/
POS/131535Z8/JUN/3600N9/01400E5/AIS//1NM/1NM/054T/08.5K////OWN//NPH/1
RMKS/1/9125085/304302000/UNK
RMKS/2/CHIOGGIA//170800Z6/JUN
RMKS/3/LPOC UNK//ETD UNK/
CTC/T00002/UNEQUATED-LPG/C GAZ REDSEA//TMO/UNK//PA///NSP/00//////
/HOBV/
POS/131758Z5/JUN/3601N0/01456E6/AIS//1NM/1NM/078T/00.1K////OWN//NPH/1
RMKS/1/9264192/353130000/UNK
RMKS/2/HURDBANK FOR ORDER//101230Z7/JUN
RMKS/3/LPOC UNK//ETD UNK/
CTC/T00003/UNEQUATED-JOLLY GRIGIO//TM/UNK//IT///NSP/00///////IBSZ/
POS/131758Z5/JUN/3254N4/01311E6/AIS//1NM/1NM/348T/00.0K////OWN//NPH/1
RMKS/1/7616353/247134000/UNK
RMKS/2/TRIPOLI//111200Z5/JUN
RMKS/3/LPOC UNK//ETD UNK/
CTC/T00004/UNEQUATED-UNKNOWN///UNK//DE///NSP/00////////
POS/131421Z2/JUN/3734N7/01624E3/AIS//1NM/1NM/112T/19.0K////OWN//NPH/1
RMKS/1/0000000/211378370/UNK
RMKS/2/NPOC UNK//ETA UNK/
RMKS/3/LPOC UNK//ETD UNK/

Alors voila, il y a des bateaux qui ne sont pas reconnu, les « UNEQUATED-UNKNOWN » (le CTC04) il faudrait qu en cliquant sur un bouton, il me supprime tout ce qui concerne ce bateau, donc la ligne CTC, la ligne POS et les lignes RMKS qui corresponde a ce bateau, donc en gros la ligne CTC et les 3 lignes qui suivent si quelqu un peut m aider a faire ca ou sur excell ou sur word ce serait super sympa, car je suis vraiment une buse en programmation, mais ca m aidera énormément

bien sur si il y a 200 bateaux inconnus, il faudrait qu il me les supprimes tous, vu qu'ils auront tous le meme format de texte

Merci d'avance

Bonsoir à tous
Bonsoir blade2a

Les textes sont en colonne A. Essaie ceci, si j'ai compris ta demande :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Option Explicit
 
Sub recherche_supprime_unknown()
 
Dim a As Long
Dim c As Range
Dim firstAddress As String
Dim i As Long
Dim ligne As Long
Dim tablo()
Dim Var As String
 
i = 1
ReDim tablo(i)
With Worksheets("Feuil1").Range("a:a")
Var = "UNEQUATED-UNKNOWN"
 
    Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlPart)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            tablo(i) = c.Row
            i = i + 1
            ReDim Preserve tablo(i)
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
 
For a = i - 1 To 1 Step -1
    Rows(tablo(a) & ":" & tablo(a) + 4).Delete
Next a
 
End Sub

Cela supprime les 5 lignes.
Je n'ai pas trop tester.
Eric

14/06/2012, 12h21
blade2a

Le code marche niquel, un dernier coup de pouce, comment faire pour supprimer toutes les RMKS/2 et RMKS/3 qui sont sous ce format :

RMKS/2/NPOC UNK//ETA UNK/
RMKS/3/LPOC UNK//ETD UNK/

car il y a des bateau qui ne sont pas UNEQUATED_UNKNOWN mais qui n'ont pas de remarques 2 et 3, donc comment faire pour lui dire si RMKS/2/NPOC UNK//ETA UNK/ le supprimer et si RMKS/3/LPOC UNK//ETD UNK/ le supprimer aussi ?

merci

Bonjour à tous
Bonjour blade2a

Ce pourrait être quelque chose comme ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit
 
Sub supprime_RMKS2_RMKS3()
 
Dim a As Long
Dim b As Long
Dim c As Range
Dim firstAddress As String
Dim i As Long
Dim tablo()
Dim Var As String
 
i = 1
ReDim tablo(i)
For b = 1 To 2
    With Worksheets("Feuil3").Range("a:a")
        If b = 1 Then Var = "RMKS/2/NPOC UNK//ETA UNK/"
        If b = 2 Then Var = "RMKS/3/LPOC UNK//ETD UNK/": i = 1
 
        Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlWhole)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                tablo(i) = c.Row
                i = i + 1
                ReDim Preserve tablo(i)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
 
    For a = i - 1 To 1 Step -1
        Rows(tablo(a)).Delete
    Next a
 
    Erase tablo
    ReDim tablo(i)
Next b
 
End Sub

à tester bien évidemment
Eric

15/06/2012, 01h03
blade2a

Non il ne marche pas .... pas celui la il y a aucune action sur le message

Merci

Autant pour moi, la macro doit surement marcher mais je ne peux pas la tester, car je ne sais pas pourquoi, j ai crée un deuxieme bouton, mais peux importe la macro que je met dessus , le bouton ne marche pas (j ai essayé de mettre la meme macro que le 1er bouton pour tester et ca marche meme pas alors que sur le 1er elle marche bien ...)

Je souhaiterai faire une macro qui me permetterai de supprimer toutes les lignes comprenant le mot"NPOC UNK"
pour info, il y a environ 500 ligne et uniquement dans la colonne A et le mot doit revenir dans environ 100 lignes

Bonjour à tous
Bonjour blade2a

Le nouveau code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Option Explicit
 
Sub recherche_supprime_unknown()
 
Dim a As Long
Dim c As Range
Dim firstAddress As String
Dim i As Long
Dim tablo()
Dim Var As String
 
Application.ScreenUpdating = False
i = 1
ReDim tablo(i)
With Worksheets("Feuil1").Range("a:a")
Var = "UNEQUATED-UNKNOWN"
 
    Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlPart)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            tablo(i) = c.Row
            i = i + 1
            ReDim Preserve tablo(i)
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
 
For a = i - 1 To 1 Step -1
    Rows(tablo(a) & ":" & tablo(a) + 4).Delete
Next a
 
supprime_RMKS2_RMKS3
 
Application.ScreenUpdating = True
 
End Sub
 
Sub supprime_RMKS2_RMKS3()
 
Dim a As Long
Dim b As Long
Dim c As Range
Dim firstAddress As String
Dim i As Long
Dim tablo()
Dim Var As String
 
i = 1
ReDim tablo(i)
For b = 1 To 3
    With Worksheets("Feuil2").Range("a:a")
        If b = 1 Then Var = "RMKS/2/NPOC UNK//ETA UNK/"
        If b = 2 Then Var = "RMKS/3/LPOC UNK//ETD UNK/"
 
        Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlWhole)
 
        If b = 3 Then Var = "NPOC UNK": Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlPart)
 
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                tablo(i) = c.Row
                i = i + 1
                ReDim Preserve tablo(i)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
 
    For a = i - 1 To 1 Step -1
        Rows(tablo(a)).Delete
    Next a
 
    Erase tablo
    i = 1
    ReDim tablo(i)
Next b
 
End Sub

Tu mets tout dans un module, et tu n'as qu'un seul bouton.
LA deuxième macro ne fonctionnait pas car j'avais mis

Code:

With Worksheets("Feuil2").Range("a:a")

Pour le problème de bouton je ne comprends pas pourquoi.

Pour ta 3ème demande, la suppression de la ligne contenant "NPOC UNK", était dans la 2ème demande : effacement de "RMKS/2/NPOC UNK//ETA UNK/", à moins qu'il y en ai dans d'autres lignes !

A tester
Eric

15/06/2012, 09h10
blade2a

Cela marche impeccable !!! merci beaucoup

Bonjour à tous
Bonjour blade2a

Je t'ai donné un code un peu rapidement, et je trouve qu'il était loin d'être bien. Je te donne une nouvelle mouture un peu plus aboutie, mais elle est certainement encore améliorable :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Option Explicit
 
Sub recherche_supprime_UNKNOWN_RMKS2_RMKS3_NPOC()
 
Dim a As Long
Dim b As Long
Dim c As Range
Dim firstAddress As String
Dim i As Long
Dim tablo()
Dim Var As String
 
Application.ScreenUpdating = False
i = 1
ReDim tablo(i)
For b = 1 To 4
    '*************************
    ' nom de la feuille à adapter
    '*************************
    With Worksheets("Feuil2").Range("a:a")
        If b = 1 Then Var = "RMKS/2/NPOC UNK//ETA UNK/"
        If b = 2 Then Var = "RMKS/3/LPOC UNK//ETD UNK/" ': i = 1
 
        Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlWhole)
 
        If b = 3 Then Var = "NPOC UNK": Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlPart) ': i = 1
        If b = 4 Then Var = "UNEQUATED-UNKNOWN": Set c = .Find(Var, LookIn:=xlValues, Lookat:=xlPart)
 
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                tablo(i) = c.Row
                i = i + 1
                ReDim Preserve tablo(i)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
 
    If b < 4 Then
        For a = i - 1 To 1 Step -1
            Rows(tablo(a)).Delete
        Next a
    Else
        For a = i - 1 To 1 Step -1
            Rows(tablo(a) & ":" & tablo(a) + 4).Delete
        Next a
    End If
 
    Erase tablo
    i = 1
    ReDim tablo(i)
Next b
 
Application.ScreenUpdating = True
End Sub

Fais attention à 2 choses:
- le nom de la feuille
- le nom de la procédure
et teste le.
Eric

26/06/2012, 01h26
blade2a

Salut, en fait dans la formule, il faut d abord faire la macro avec le "UNEQUATED-UNKNOWN et les 4 lignes en moin et ensuite supprimer les LPOC et NPOC stp