Macro à modifiée

Bonjour à tous

Peut on faire en sorte qu'il copy tous les cells avec le mot impair a la suite de A10 pas juste la premiere

Sub DeleteCells4()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim rng As Range, i As Long '// modified

'Set the range to evaluate to rng. // modified
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
If rng Is Nothing Then
MsgBox "nothing in Intersected range to be checked"
GoTo done
End If

'Loop backwards through the rows
'in the range that you want to evaluate.
'--- For i = rng.Rows.Count To 1 Step -1 // modified

For i = rng.Count To 1 Step -1

'If cell i in the range contains an "Impair", delete the entire row.
If rng.Cells(i).Value = "Impair" Then rng.Cells(i).EntireRow.Select
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Selection.Cut
Range("A10").Select
ActiveSheet.Paste
End Sub

Merci

Temjeh