Sub Extract()
Dim Onglets, Ongl
Dim FRp As Worksheet
Dim Plg As Range, Cel As Range
Dim DerligR As Long, DerLigR2 As Long
Dim I As Byte
Dim Flag As Boolean
Application.ScreenUpdating = False
Onglets = Array("ZONE1", "ZONE2")
Set FRp = Sheets("Report")
Set Cel = FRp.Range("A2")
With FRp
DerligR = .Cells(Rows.Count, "A").End(xlUp).Row
If DerligR > 6 Then .Range("A7:J" & Rows.Count).Clear
End With
For Each Ongl In Onglets
With Sheets(Ongl)
Set Plg = .Range("A4:J" & .Cells(Rows.Count, "A").End(xlUp).Row)
FRp.Range("B1") = Cel.Offset(-1): FRp.Range("B2") = Cel
FRp.Range("C2").FormulaR1C1 = "=" & Ongl & "!R[3]C7<>"""""
If Ongl = "ZONE2" And Not Flag Then
DerligR = FRp.Cells(Rows.Count, "A").End(xlUp).Row + 4
FRp.Rows("4:6").Copy FRp.Cells(DerligR, 1)
FRp.Cells(DerligR, 1) = Ongl
Flag = True
End If
For I = 0 To 1
DerligR = FRp.Cells(Rows.Count, "A").End(xlUp).Row + 1
If I = 1 Then
If IsNumeric(FRp.Cells(DerligR - 1, "D")) Then DerligR = DerligR + 2
End If
Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FRp.Range("B1:C2"), _
CopyToRange:=FRp.Cells(DerligR, 1), Unique:=False
FRp.Rows(DerligR).Delete
DerLigR2 = FRp.Cells(Rows.Count, "A").End(xlUp).Row + 1
If DerLigR2 > DerligR Then
FRp.Cells(DerLigR2, "D") = Application.Sum(FRp.Cells(DerligR, "D").Resize(DerLigR2 - DerligR))
FRp.Cells(DerLigR2, "E") = Application.Sum(FRp.Cells(DerligR, "E").Resize(DerLigR2 - DerligR))
If Application.CountIf(FRp.Cells(DerLigR2, "D").Resize(1, 2), 0) = 0 Then
FRp.Cells(DerLigR2, "F") = Cells(DerLigR2, "E") / Cells(DerLigR2, "D")
FRp.Cells(DerLigR2, "F").NumberFormat = "0.00%"
End If
End If
FRp.Range("B2") = FRp.Range("B2") + 1
Next I
End With
Next Ongl
FRp.Range("B1:C2").Clear
End Sub