Sub test()
Dim TBase() As Variant
TBase = Range(Cells(4, 9), Cells(5, 8770))
Dim Tres As Variant
ReDim Tres(LBound(TBase, 1) To UBound(TBase, 1), LBound(TBase, 2) To UBound(TBase, 2))
Dim CopiExcel() As Variant
ReDim CopiExcel(1 To 1, 1 To 7)
Dim cpt As Long: cpt = 0
Dim NumExtract As Long: NumExtract = 1
' nettoyage de la zone
' --------------------
Range(Cells(10, 2), Cells(1048576, 8)).ClearContents
' Enregistre les séries de 8H supérieur a 100
' -------------------------------------------
For i = LBound(TBase, 2) + 1 To UBound(TBase, 2)
'If i = 3326 Or cpt > 8 Then
'Cells(5, i + 8).Select
'End If
For j = i To i + 8
If TBase(2, j) > 100 Then
Tres(1, j) = TBase(1, j)
Tres(2, j) = TBase(2, j)
cpt = cpt + 1
If cpt = 8 And (j - i + 1) = 8 Then
CopiExcel(1, 1) = NumExtract
CopiExcel(1, 2) = Format(Split(Tres(1, j - 7), " ")(0), "dd mmm") ' Date (Début)
CopiExcel(1, 3) = Format(Split(Tres(1, j - 7), " ")(1), "h\Hmm") ' heure (Début)
CopiExcel(1, 4) = Format(Split(Tres(1, j), " ")(0), "dd mmm") ' Date (Fin)
CopiExcel(1, 5) = Format(Split(Tres(1, j), " ")(1), "h\Hmm") ' heure (Fin)
For k = i To i + 8
If TBase(2, k) >= 100 And TBase(2, k) < 120 Then
CopiExcel(1, 6) = "Oui"
ElseIf TBase(2, k) > 120 Then
CopiExcel(1, 7) = "Oui"
End If
Next k
cpt = 0
i = j
NumExtract = NumExtract + 1
'Cells(Cells(65536, 2).End(xlUp).Row + 1, 2).Select
Cells(Cells(65536, 2).End(xlUp).Row + 1, 2).Resize(LBound(CopiExcel, 1), UBound(CopiExcel, 2)) = CopiExcel
Exit For
ElseIf cpt <> 8 And (j - i + 1) = 8 Then
For k = i To i + 8
Tres(1, k) = ""
Tres(2, k) = ""
Next k
cpt = 0
Exit For
End If
Else
cpt = 0
Exit For
End If
Next j
Next i
End Sub