Une macro pour supprimer des lignes dans un message

**blade2a** · 13/06/2012, 20h53

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

**edelweisseric** · 14/06/2012, 00h10

Bonsoir à tous
Bonsoir blade2a

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**blade2a** · 14/06/2012, 12h21

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

**edelweisseric** · 14/06/2012, 14h17

Bonjour à tous
Bonjour blade2a

Ce pourrait être quelque chose comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**blade2a** · 15/06/2012, 01h03

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

**edelweisseric** · 15/06/2012, 08h36

Bonjour à tous
Bonjour blade2a

Le nouveau code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**blade2a** · 15/06/2012, 09h10

Cela marche impeccable !!! merci beaucoup

**edelweisseric** · 16/06/2012, 17h14

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**blade2a** · 26/06/2012, 01h26

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

Une macro pour supprimer des lignes dans un message

Macros et VBA Excel

Discussions similaires

Partager

Partager