Option Explicit
Sub Test()
Dim Derligne As Long
Dim C As Range
Application.ScreenUpdating = False
Sheets("Extraction").Range("A1:F" & Rows.Count).ClearContents
With Sheets("Données")
Derligne = .Range("B" & Rows.Count).End(xlUp).Row
If Derligne > 1 Then
For Each C In .Range("A1:A" & Derligne - 1).SpecialCells(xlCellTypeBlanks)
If C.Offset(0, 2) >= 30 Then
C.Offset(-1, 1).Resize(1, 6).Copy
Sheets("Extraction").Range("B" & Rows.Count).End(xlUp).Offset(1, -1).PasteSpecial Paste:=xlPasteValues
Else
Exit Sub
End If
Next C
End If
Derligne = .Range("B" & Rows.Count).End(xlUp).Row
If Derligne > 1 Then
For Each C In .Range("A1:A" & Derligne - 1).SpecialCells(xlCellTypeBlanks)
If C.Offset(0, 2) >= 30 Then
C.Offset(0, 2).Resize(1, 1).Copy
Sheets("Extraction").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If
Next C
End If
End With
'Préparation pour la copie des données vers la feuille du mois en cours
Application.DisplayAlerts = False
Sheets("Extraction").Select
Columns("B:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Derligne = Range("A" & Rows.Count).End(xlUp).Row
If Derligne > 1 Then
Selection.SpecialCells(xlCellTypeLastCell).Select
Selection.Offset(0, -6).Formula = "=SUM(E:E)"
Range("A1").CurrentRegion.Select
Selection.Copy
End If
End Sub