Discussion :

[arnold95]

Bonjour, j'ai un souci dans ma boucle. Le but de ma macro est d'éliminer les lignes de la "feuil1" qui ne répondent pas aux conditions et de les copier sur une autre feuille (feuil 2).Voici ma macro:

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
Sub macro()
derniereLigne = ActiveSheet.UsedRange.Rows.Count
For r = derniereLigne To 1 Step -1
Sheets("feuil1").Select
If Sheets("feuil1").Range("P" & r).Value = "Vrai" Then
    If Sheets("feuil1").Range("Q" & r).Value = "Vrai" Then
        If Sheets("feuil1").Range("R" & r).Value = "Vrai" Then
            If Sheets("feuil1").Range("S" & r).Value = "Vrai" Then
                Cells(r, "A").EntireRow.Copy
                Rows(r).Delete
                Lign = Worksheets("feuil2").Cells(Cells.Rows.Count, "A").End(xlUp).Row
                Worksheets("feuil2").Select
                Cells(Lign + 1, 1).Paste
            End If
        End If
    End If
End If
Next r
End Sub

Merci, Bonne soirée et Joyeux noel.

[Singular]

Plutôt 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
Sub macro()
    Dim r As Long
    Dim derniereLigne As Long
    Dim wks1 As Worksheet
    Dim rng As Range
 
    Set wks1 = Worksheets("Feuil1")
    derniereLigne = wks1.UsedRange.Rows.Count
    For r = derniereLigne To 1 Step -1
        If wks1.Range("P" & r).Value = "Vrai" Then
            If wks1.Range("Q" & r).Value = "Vrai" Then
                If wks1.Range("R" & r).Value = "Vrai" Then
                    If wks1.Range("S" & r).Value = "Vrai" Then
                        wks1.Cells(r, 1).Resize(1, wks1.UsedRange.Columns.Count).Copy
                        Set rng = Worksheets("Feuil2").UsedRange
                        If rng.Cells.Count = 1 Then
                            rng.PasteSpecial
                        Else
                            rng.Offset(1, 0).PasteSpecial
                        End If
                        wks1.Cells(r, 1).EntireRow.Delete
                    End If
                End If
            End If
        End If
    Next r
End Sub

[arnold95]

Merci singular, çà me copie bien des lignes le souci c'est que c'est la même ligne qui est copiée et non celle qui est supprimée.

[Singular]

J'avais mal lu le problème, désolé.

Voilà:

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
Sub macro()
    Dim r As Long
    Dim derniereLigne As Long
    Dim wks1 As Worksheet
    Dim rng As Range
 
    Set wks1 = Worksheets("Feuil1")
    derniereLigne = wks1.UsedRange.Rows.Count
    For r = derniereLigne To 1 Step -1
        If wks1.Range("P" & r).Value = "Faux" Or _
                    wks1.Range("Q" & r).Value = "Faux" Or _
                    wks1.Range("R" & r).Value = "Faux" Or _
                    wks1.Range("S" & r).Value = "Faux" Then
            wks1.Cells(r, 1).Resize(1, wks1.UsedRange.Columns.Count).Copy
            Set rng = Worksheets("Feuil2").UsedRange
            If rng.Cells.Count = 1 Then
                rng.PasteSpecial
            Else
                rng.Cells(rng.Rows.Count + 1, 1).PasteSpecial
            End If
            wks1.Cells(r, 1).EntireRow.Delete
        End If
    Next r
End Sub

À+

[arnold95]

Effectivement çà marche. Merci beaucoup et bonne soirée