Sub Transfert()
Application.ScreenUpdating = False
Set F1 = Sheets("Ref")
Set F2 = Sheets("Qte")
N = F1.Cells(65536, 15).End(xlUp).Row
F1.Range("R6:R65536").ClearContents
F1.Range("O6:O65536").ClearContents
N = 6
With F2
For I = 12 To .Cells(65536, 17).End(xlUp).Row
If .Cells(I, 17).Value <> "" And .Cells(I, 17).Value > 0 And Cells(I, 17).Interior.ColorIndex <> 6 Then
'Si tu veux par rapport aux cellules contenant les sommes change la ligne du dessus par celle du dessous en vert sans l'apostrophe
'If .Cells(i, 17).Value <> "" And .Cells(i, 17).Value > 0 And Cells(i, 17).Interior.Color = RGB(102, 255, 153) Then
F1.Cells(N, 15) = .Cells(I, 17)
.Cells(I, 17).Copy F1.Cells(N, 15)
F1.Cells(N, 18) = .Cells(I, 2)
.Cells(I, 2).Copy F1.Cells(N, 18)
F1.Cells(N, 12) = .Cells(I, 1)
.Cells(I, 1).Copy F1.Cells(N, 12)
N = N + 1
End If
Next I
End With
Application.CutCopyMode = False
End Sub