Supprimer des lignes en fonction de la valeur de la cellule de deux colonnes

**jérémyp8** · 02/07/2013, 09h45

Bonjour,

J'ai une macro qui m'extrait une quantité (une partie) de données de chaque document Word

Pour chaque document word la macro m extraire
sur la colonne A Le Nom du projet,
Sur la colonne B tous les Systemes d'exploitation OS
Sur la colonne C toutes les versions OS
........
........
et
Sur la colonne I la derniere date de modification de chaque document Word

Remarque :
Je laisse a chaque fois une ligne vide entre chaque partie de donnée extraite d'un seul document Word sur mon fichier Excel

Le test à faire : c'est de faire un parcours en gardant la date de modification la plus récente une fois ceci fait reparcourir en virant les données inutiles.
Et ce tant que la titre d'après est différent de celui d'avant (en descendant dans ta colonne)

Ci joint mon fichier Excel des données déjà extraites ou je veux integerer le test

Merciii

**EngueEngue** · 02/07/2013, 10h21

La structuration rend le code hyper compliqué.
Tu devrais éviter de sauter des lignes et remplir les cases vides de la colonne A et I..

**jérémyp8** · 02/07/2013, 10h26

Bonjour EngueEngue,

Merci pour ta réponse

Et dans le cas ou je ne laisserai pas de lignes, ( supposant que j'ai pas de lignes vides choses dont je peux m'empasser ) es ce que tu as une idée (un code) comment réaliser ce test ?

Merci

**EngueEngue** · 02/07/2013, 10h38

S'il n'y avait qu'une seule ligne par document:

Sachant qu'il peut y en avoir plusieurs une technique serait de faire l'opération et de remplir les lignes que tu as supprimé.

Code :

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

1
2
3
4
5
6
7
8
9
10
sub toto
dim i as long
With feuil1
For i = 3 to .range("A1048576").end(xlup).row
if .cells(i,1) = .cells(i+1,1) and .cells(i,9)<.cells(i+1,9)
.Row(i).Delete
end if
next i
end with
end sub

Je me creuserais les méninges une fois que tu auras restructuré correctement

**jérémyp8** · 03/07/2013, 10h00

Bonjour EngueEngue

J'ai testé ton code mais il rien ne se passe pas de supprission des lignes
voila la macro

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub test()
Dim i As Long
With ThisWorkbook.Sheets("Feuil1")
For i = 3 To .Range("A1048576").End(xlUp).Row
If .Cells(i, 1) = .Cells(i + 1, 1) And .Cells(i, 9) < .Cells(i + 1, 9) Then
.Row(i).Delete
End If
Next i
End With
End Sub

Puis j'ai pas compris ta phrase : Sachant qu'il peut y en avoir plusieurs une technique serait de faire l'opération et de remplir les lignes que tu as supprimé ?

Merci

**Daniel.C** · 03/07/2013, 11h00

Bonjour,

Que faire quand deux projets ont la même date ?

**jérémyp8** · 03/07/2013, 11h05

Bonjour Daniel.C

Très bonne question au quelle j'ai pas pensé

...mais je ne pense pas que je vais avoir ce genre de cas car dans ma colonne date de modification ya aussi l'heure de la modification

STP es ce que tu sais comment realiser ce test ? je te serai très reconnaissant

Merci

Invité · 03/07/2013, 11h14

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Sub test()
    Dim i As Long
    Dim MyRange As Range
    Set MyRange = ActiveWorkbook.Sheets("Feuil1").UsedRange
 
    For i = MyRange.Rows.Count To 3 Step -1
        If MyRange(i, 1) = MyRange(i + 1, 1) And MyRange(i, 9) < MyRange(i + 1, 9) Then
            MyRange(i, 1).EntireRow.Delete
        End If
    Next i
End Sub

**jérémyp8** · 03/07/2013, 11h21

Bonjour rdurupt

Merci pour ta réponse et de s'intresser a mon Pb

Je viens de tester ton code, il se passe rien du tout

**Daniel.C** · 03/07/2013, 11h26

dans ma colonne date de modification ya aussi l'heure de la modification

Justement, dans ton classeur, tu à la même date et heure pour le projet "JEDI G1R5 PPM". Je modifie une heure, pour voir.

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
Sub test()
    Dim C As Range, Dico As Object
    Set Dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        'recopie du projet et de la date
        For Each C In .Range(.[B4], .Cells(.Rows.Count, 2).End(xlUp))
            If C.Value <> "" Then
                If C.Offset(, -1) = "" Then C.Offset(, -1) = C.Offset(-1, -1)
                If C.Offset(, 7) = "" Then C.Offset(, 7) = C.Offset(-1, 7)
            End If
        Next C
        'suppression des lignes vides
        For i = .Cells(.Rows.Count, 2).End(xlUp).Row To 4 Step -1
            If .Cells(i, 2) = "" Then Rows(i).Delete
        Next i
        'on marque avec un "x" dans la date les lignes à supprimer
        For Each C In .Range(.[B4], .Cells(.Rows.Count, 2).End(xlUp))
            If Not Dico.Exists(C.Offset(, -1).Value) Then
                Dico.Add C.Offset(, -1).Value, C.Offset(, -1).Value
                .AutoFilterMode = False
                .Range(.[A2], .Cells(.Rows.Count, 9).End(xlUp)).AutoFilter 1, C.Offset(, -1).Value
                Set plage = .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)
                For Each x In plage
                    If x.Value < Application.Subtotal(104, .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)) Then
                        x.Value = "x"
                    End If
                Next x
            End If
        Next C
        .AutoFilterMode = False
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
            If .Cells(i, 9) = "x" Then Rows(i).Delete
        Next i
        'ajout de lignes vides
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 5 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                .Cells(i, 1) = ""
                .Cells(i, 9) = ""
            Else
                .Rows(i).Insert
            End If
        Next i
    End With
End Sub

**jérémyp8** · 03/07/2013, 11h36

Re Daniel.C

Ta macro fonctionne a MERVEILLE

Vraiment un grand merci a toi en plus c'est pas la première fois que tu m'apporte ta précieuse aide, sans toi je pense pas que je y arriverai a régler ce Pb

Encore une fois Merci et porte toi bien

**jérémyp8** · 11/07/2013, 14h38

Bonjour Daniel.C

C'est encore moi

C'est vrai qu'avant j'ai déjà mis RESOLU pour ce sujet parce que tout fonctionnait a merveille mais en faisant un test sur un autre fichier Excel j'ai constaté que la macro donne un Résultat Faux et Beug aussi

Je ne comprends pas c'est quoi le Pb ?

Je te joins le fichier en question

Mercii

**Daniel.C** · 11/07/2013, 17h31

Effectivement. Un truc auquel je n'aurais jamais pensé... Je vais approfondir. En attendant, modifie la macro commme suit :

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
Sub SupProjet()
 
    Dim C As Range, Dico As Object
 
    Set Dico = CreateObject("Scripting.Dictionary")
 
    With Sheets("Feuil1")
 
'Recopie du projet et de la date
    For Each C In .Range(.[B4], .Cells(.Rows.Count, 2).End(xlUp))
 
            If C.Value <> "" Then
 
                If C.Offset(, -1) = "" Then C.Offset(, -1) = C.Offset(-1, -1)
                If C.Offset(, 7) = "" Then C.Offset(, 7) = C.Offset(-1, 7)
            End If
        Next C
 
'Suppression des lignes vides
        For i = .Cells(.Rows.Count, 2).End(xlUp).Row To 4 Step -1
            If .Cells(i, 2) = "" Then Rows(i).Delete
        Next i
 
'On marque avec un "x" dans la date les lignes à supprimer
    For Each C In .Range(.[B4], .Cells(.Rows.Count, 2).End(xlUp))
 
        If Not Dico.Exists(C.Offset(, -1).Value) Then
 
                Dico.Add C.Offset(, -1).Value, C.Offset(, -1).Value
                .AutoFilterMode = False
                .Range(.[A2], .Cells(.Rows.Count, 9).End(xlUp)).AutoFilter 1, C.Offset(, -1).Value
    Set plage = .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp))
    If plage.Cells.Count > 1 Then
        Set plage = .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)
    End If
For Each x In plage
        If x.Value < Application.Subtotal(104, .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)) Then
           x.Value = "x"
                    End If
                Next x
            End If
        Next C
        .AutoFilterMode = False
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
            If .Cells(i, 9) = "x" Then Rows(i).Delete
        Next i
 
'Ajout de lignes vides
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 5 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                .Cells(i, 1) = ""
                .Cells(i, 9) = ""
            Else
                .Rows(i).Insert
            End If
        Next i
    End With
End Sub

**jérémyp8** · 12/07/2013, 09h38

Bonjour Daniel.C

Tout marche très bien

Un enorme merci et Respect a toi

**jérémyp8** · 15/07/2013, 11h33

Re Daniel.C

C'est encore ...j'espère que je te dérange pas mais c'est un peu urgent

J'ai un problème à propos de ta Marco

Comme tu as pu remarquer sur le fichier Excel que je tai joins

Regarde quant Ya deux projets identiques avec deux dates modification différentes
Quand j'exécute la macro j’ai bien que le projet qui la dernière date de modification mais cette macro me supprime quelques lignes de données

Regarde colonne pour les deux projets Tipi G1R2, code Basicat :36P

Au début dans la colonne Was Server on 11 donnée mais quand je lance la macro il me reste que 2

Merci bcp

**Daniel.C** · 15/07/2013, 12h20

Bonjour,

Essaie comme ça :

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
Sub SupProjet()
 
    Dim C As Range, Dico As Object, DerLig As Long
 
    Set Dico = CreateObject("Scripting.Dictionary")
 
    With Sheets("Feuil1")
 
'Recopie du projet et de la date
    DerLig = .[A:I].Find("*", , , , xlByRows, xlPrevious).Row
    For Each C In .Range(.[B4], .Cells(DerLig, 2))
 
            If C.Value <> "" Or C.Offset(, 4) <> "" Then
 
                If C.Offset(, -1) = "" Then C.Offset(, -1) = C.Offset(-1, -1)
                If C.Offset(, 7) = "" Then C.Offset(, 7) = C.Offset(-1, 7)
            End If
        Next C
 
'Suppression des lignes vides
        For i = DerLig To 4 Step -1
            If .Cells(i, 1) = "" Then Rows(i).Delete
        Next i
 
'On marque avec un "x" dans la date les lignes à supprimer
    For Each C In .Range(.[B4], .Cells(.Rows.Count, 2).End(xlUp))
 
        If Not Dico.Exists(C.Offset(, -1).Value) Then
 
                Dico.Add C.Offset(, -1).Value, C.Offset(, -1).Value
                .AutoFilterMode = False
                .Range(.[A2], .Cells(.Rows.Count, 9).End(xlUp)).AutoFilter 1, C.Offset(, -1).Value
    Set plage = .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp))
    If plage.Cells.Count > 1 Then
        Set plage = .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)
    End If
For Each x In plage
        If x.Value < Application.Subtotal(104, .Range(.[I4], .Cells(.Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)) Then
           x.Value = "x"
                    End If
                Next x
            End If
        Next C
        .AutoFilterMode = False
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
            If .Cells(i, 9) = "x" Then Rows(i).Delete
        Next i
 
'Ajout de lignes vides
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 5 Step -1
            If .Cells(i, 1) = .Cells(i - 1, 1) Then
                .Cells(i, 1) = ""
                .Cells(i, 9) = ""
            Else
                .Rows(i).Insert
            End If
        Next i
    End With
End Sub

**jérémyp8** · 18/07/2013, 09h25

Bonjour Daniel.C

Maintenant tout fonctionne bien

Merciii

Supprimer des lignes en fonction de la valeur de la cellule de deux colonnes [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager