Suppression d'une ligne sur deux

**pimpom81** · 20/08/2012, 10h44

Bonjour le Forum,

Suite à une discussion précédente "Copier/coller avec PasteSpecial impossible" Mercatog avait trouvé une solution qui me convient.
Sauf que maintenant le problème est tout autre, puisque lorsque je veux supprimer les lignes copier puis coller, je m'apperçoit qu'une ligne sur deux est supprimée.

Voici le 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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
Private Sub Afficher_Click()
Dim LastLigS1 As Long, LastLigS2 As Long, NewLigC1 As Long, NewLigC2 As Long, NewLigC3 As Long, i As Long
Dim Année As Integer, Avct As String
Dim c As Range, d As Range, e As Range
 
Application.ScreenUpdating = False
 
'Ouvrir le fichier "Archives observations"
Set Wbk = Workbooks.Open("E:\Rapports d'audits EHS\Archives observations.xlsm")
Annee = CbB_Archivage.Value
Avct = "100%"
Set WsC1 = Wbk.Worksheets("Archive des données")                    '1ère feuille cible
Set WsC2 = Wbk.Worksheets("Archive des Actions Soldées")            '2ème feuille cible
Set WsC3 = Wbk.Worksheets("Liste")                                  '3ème feuille cible
Set WsS1 = Workbooks("HRQF898-01").Worksheets("Recueil données")    '1ère feuille source
Set WsS2 = Workbooks("HRQF898-01").Worksheets("Rapport")            '2ème feuille source
Set WsS3 = Workbooks("HRQF898-01").Worksheets("Suivi mensuel")      '3ème feuille source
 
'Extraction du nombre d'observations ouvertes vers fichier archivage
NewLigC3 = WsC3.Cells(WsC3.Rows.Count, 6).End(xlUp).Row + 1
    With WsS3
        'Copie des lignes à sélectionner dans cellules de destinations
        Set e = .Range("Y47:Z47")
        If Not e Is Nothing Then
            'Copier
            e.Copy
            'Collage spécial
            WsC3.Cells(NewLigC3, 6).PasteSpecial Paste:=xlPasteValues
            Set e = Nothing
            NewLigC3 = NewLigC3 + 1
        End If
    End With
NewLigC3 = 0
Set WsC3 = Nothing
 
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
If Annee = CbB_Archivage.Value Then
    NewLigC1 = WsC1.Cells(WsC1.Rows.Count, 1).End(xlUp).Row + 1
    With WsS1
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLigS1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        If LastLigS1 >= 171 Then
            For i = 171 To LastLigS1
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    'Copier
                    c.EntireRow.Copy
                    'Collage spécial
                    WsC1.Cells(NewLigC1, 1).PasteSpecial Paste:=xlPasteValues
                    Set c = Nothing
                    NewLigC1 = NewLigC1 + 1
                End If
            Next i
            For i = 171 To LastLigS1
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    'Suppression
                    c.EntireRow.Delete
                    Set c = Nothing
                End If
            Next i
        End If
    End With
NewLigC1 = 0
End If
Set WsC1 = Nothing
 
'Extraction des lignes = à l'année passée, de "Rapport"  vers fichier archivage
If Annee = CbB_Archivage.Value Then
    NewLigC2 = WsC2.Cells(WsC2.Rows.Count, 1).End(xlUp).Row + 1
    With WsS2
        'Démasquage de colonnes
        WsS2.Columns("A:F").EntireColumn.Hidden = False
        WsS2.Columns("P:AA").EntireColumn.Hidden = False
 
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLigS2 = .Cells(.Rows.Count, 1).End(xlUp).Row
        'Désactivation de tous les filtres "gpe de section" et "avancement"
        .Range("$A$26:$Q$" & LastLigS2).AutoFilter Field:=4   '"gpe de section"
        .Range("$A$26:$Q$" & LastLigS2).AutoFilter Field:=6   '"Opé/poste"
        .Range("$A$26:$Q$" & LastLigS2).AutoFilter Field:=15  '"avancement"
 
        'Activation des filtres de la colonne "Avct"
        .Range("$A$26:$Q$" & LastLigS2).AutoFilter Field:=15, Criteria1:="100%"
        If LastLigS2 >= 27 Then
            For i = 27 To LastLigS2
                Set d = .Range("A" & i & ":Q" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not d Is Nothing Then
                    'Copier
                    d.EntireRow.Copy
                    'Collage spécial
                    WsC2.Cells(NewLigC2, 1).PasteSpecial Paste:=xlPasteValues
                    Set d = Nothing
                    NewLigC2 = NewLigC2 + 1
                End If
            Next i
            For i = 27 To LastLigS2
                Set d = .Range("A" & i & ":Q" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not d Is Nothing Then
                    'Suppression
                    d.EntireRow.Delete
                    Set d = Nothing
                End If
            Next i
        End If
 
        .Range("$A$26:$Q$" & LastLigS2).AutoFilter Field:=15, Criteria1:=Array("0%", "25%", "50%", "75%", "="), Operator:=xlFilterValues
 
        WsS2.Columns("A:F").EntireColumn.Hidden = True
        WsS2.Columns("P:AA").EntireColumn.Hidden = True
 
    End With
NewLigC2 = 0
End If
Set WsC2 = Nothing
 
Application.ScreenUpdating = True
 
With Workbooks("Archives observations")
    .Save
    .Close
End With
 
Unload Me
 
End Sub

NB: Les lignes 54 à 61 et 97 à 104 sont des essais sur le code de suppression, à l'origine ça ressemblait à ceci, et j'obtenai le même résultat

Code :

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

1
2
3
4
5
6
7
8
9
10
 
If Not d Is Nothing Then
   'Copier
   d.EntireRow.Copy
   'Collage spécial
   WsC2.Cells(NewLigC2, 1).PasteSpecial Paste:=xlPasteValues
   'Suppression
   d.EntireRow.Delete
   NewLigC2 = NewLigC2 + 1
End If

Quelqu'un aurait l'aimaible gentillesse

de m'aider sur ce problème?

Cordialement

**Jean-Philippe André** · 20/08/2012, 10h56

Salut,

pour les codes de suppression de lignes Excel, on a tendance à partir de la ligne "d'en bas" et de remonter jusqu'"en haut"

Tu éviteras aussi les incréments de variable et des lignes qui passeraient au travers des mailles du filet.

Un boucle For avec Step de -1 devrait suffire ici

**pimpom81** · 20/08/2012, 11h30

Salut Jpcheck,

J'ai essayé de boucler avec le step -1
Permier essai => aucune ligne supprimée

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
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
If Annee = CbB_Archivage.Value Then
    NewLigC1 = WsC1.Cells(WsC1.Rows.Count, 1).End(xlUp).Row + 1
    With WsS1
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLigS1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        If LastLigS1 >= 171 Then
            For i = 171 To LastLigS1
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    'Copier
                    c.EntireRow.Copy
                    'Collage spécial
                    WsC1.Cells(NewLigC1, 1).PasteSpecial Paste:=xlPasteValues
                    Set c = Nothing
                    NewLigC1 = NewLigC1 + 1
                End If
            Next i
            For i = 171 To LastLigS1 Step -1
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    'Suppression
                    c.EntireRow.Delete
                    Set c = Nothing
                End If
            Next i
        End If
    End With
NewLigC1 = 0
End If
Set WsC1 = Nothing

Second essai => aucune action de copie ni de suppression de lignes

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
'Extraction des lignes = à l'année passée, de "Recueil données"  vers fichier archivage
If Annee = CbB_Archivage.Value Then
    NewLigC1 = WsC1.Cells(WsC1.Rows.Count, 1).End(xlUp).Row + 1
    With WsS1
        'Copie des lignes à sélectionner dans cellules de destinations
        LastLigS1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        If LastLigS1 >= 171 Then
            For i = 171 To LastLigS1 Step -1
                Set c = .Range("A" & i & ":AV" & i).Find(Annee, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    'Copier
                    c.EntireRow.Copy
                    'Collage spécial
                    WsC1.Cells(NewLigC1, 1).PasteSpecial Paste:=xlPasteValues
                    'Suppression
                    c.EntireRow.Delete
                    Set c = Nothing
                    NewLigC1 = NewLigC1 + 1
                End If
            Next i
        End If
    End With
NewLigC1 = 0
End If
Set WsC1 = Nothing

???????

**Jean-Philippe André** · 20/08/2012, 11h38

Attention, si tu fais un step négatif tu dois mettre les bornes dans le bon sens

Code :

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

For i = 171 To LastLigS1

se transformant alors en

Code :

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

For i = LastLigS1 To 171 Step -1

**mercatog** · 20/08/2012, 11h45

En plus tu as

Code :

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

Annee=CbB_Archivage.Value

et tu fais le test plus bas

Code :

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

If Annee=CbB_Archivage.Value

Tu peux aussi t'en passer du Find, une CountIf suffit

Le code deviendrait

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
'Ouvrir le fichier "Archives observations"
Application.ScreenUpdating = False
Set Wbk = Workbooks.Open("E:\Rapports d'audits EHS\Archives observations.xlsm")
Annee = CbB_Archivage.Value
Avct = "100%"
 
Set Ws = Wbk.Worksheets("Archive des données")
 
With ThisWorkbook.Worksheets("Recueil données")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If LastLig >= 171 Then
        For i = LastLig To 171 Step -1
            If Application.CountIf(.Range("A" & i & ":AV" & i), Annee) > 0 Then
                .Rows(i).Copy                                                                   'Copier
                Ws.Cells(Ws.Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues       'Collage spécial
                .Rows(i).Delete                                                                 'Suppression
            End If
        Next i
    End If
End With
Set Ws = Nothing

**pimpom81** · 20/08/2012, 11h59

Re Jpcheck, Salut Mercatog

JPCHECK :

La solution est bonne, et les résultats escomptés sont obtenus, petit bémol à ça lors de la copier les lignes sont coller dans l'ordre inverse, il faut juste que je rajoute un code pour trier dans l'ordre croissant.

Merci

MERCATOG : Je vais testé ton code et je vous fais un feedback sur l'une ou l'autre des solutions choisie.

Cordialement

**mercatog** · 20/08/2012, 12h16

Tu peux insérer une ligne vide en NewLig (sans incrémenter NewLig) et y coller les données. A la fin tu n'auras pas à trier

Exemple

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
Application.ScreenUpdating = False
Set Wbk = Workbooks.Open("E:\Rapports d'audits EHS\Archives observations.xlsm")
Annee = CbB_Archivage.Value
Avct = "100%"
 
Set Ws = Wbk.Worksheets("Archive des données")
NewLig = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row + 1
With ThisWorkbook.Worksheets("Recueil données")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If LastLig >= 171 Then
        For i = LastLig To 171 Step -1
            If Application.CountIf(.Range("A" & i & ":AV" & i), Annee) > 0 Then
                Ws.Rows(NewLig).Insert                                        'insérer une ligne vide
                .Rows(i).Copy                                                 'Copier
                Ws.Range("A" & NewLig).PasteSpecial Paste:=xlPasteValues      'Collage spécial
                .Rows(i).Delete                                               'Suppression
            End If
        Next i
    End If
End With
Set Ws = Nothing

**pimpom81** · 20/08/2012, 12h25

Petite question Mercatog,

Dans la troisième partie d'extraction (à partir de la ligne 68 de mon premier post), j'ai deux conditions pour les copies, 1ère = Année, 2nde = Avct (=100%)

Est ce que l'application countif peux s'exécuter sur ces deux conditions?

Ainsi les lignes de l'année recherchée, mais dont l'Avct n'est pas égale à 100% ne seront pas supprimées. C'est un peu ce qu'il m'es arrivé en testant le code.
(Fort heuresement que ce sont des lignes fictives)

**mercatog** · 20/08/2012, 12h40

Pour les versions à partir de Excel 2007, tu peux utiliser COUNTIFS (NB.SI.ENS) qui prend en compte plusieurs critères.

**pimpom81** · 20/08/2012, 15h21

Il faut le coder comme ceci?

Code :

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

If Application.CountIfs(.Range("A" & i & ":Q" & i), Annee, .Range("A" & i & ":Q" & i), Avct) > 0 Then

J'ai essayé plusieurs méthode pour Application.CountIfs, et malheureusement je n'arrive à aucun résultats.

Je suis en panne d'idées. Aux secours.

**mercatog** · 20/08/2012, 15h27

Mea culpa, je t'avais fais perdre ton temps (j'avais mal interprété la question initiale)

Utilise plutôt 2 tests

Code :

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

If Application.CountIf(.Range("A" & i & ":Q" & i), Annee) > 0 And Application.CountIf(.Range("A" & i & ":Q" & i), Avct) > 0 Then MsgBox "ok"

Si sur la plage tu as au moins une Annee et une Avct alors....

ou

Code :

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

If Application.CountIf(.Range("A" & i & ":Q" & i),  Annee) > 0 And Application.CountIf(.Range("A" & i & ":Q"  & i), Avct) = 0 Then MsgBox "ok"

Si sur la plage tu as au moins une Annee et aucune Avct alors....

Encore une fois, désolé. Je mérite un -1.

**pimpom81** · 20/08/2012, 15h53

En fait dans une colonne (Q) j'ai l'Année et dans une colonne (O) j'ai l'Avct, sachant que les valeurs de la colonne O sont au format texte, pour des raisons d'utilisation sur une listview.

**mercatog** · 20/08/2012, 15h56

Ah alors!, il ne suffisait pas de comparer respectivement les 2 cellules?

D'abord une Find ensuite un CountIf (que de gâchis)

Code :

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

If .Range("Q" & i) = Annee And .Range("O" & i) = Avct Then

**pimpom81** · 20/08/2012, 16h08

Rooo le boulet que je suis c'était évidemment cette solution si simple qui plus est.

En tout cas merci Mercatog pour ta collaboration

On peut dire qu'un cerveau (le mien) n'est rien sans l'aide d'un autre plus rempli (le tiens)

Post résolu.

Suppression d'une ligne sur deux [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager