Bonjour, se code n'est valable que le jour j, vu que c'est un appel journalier et il est fonctionnel car je l'ai testé.
Option Base 1
Option Compare Text
Sub macro()
Feuil1.Activate
Dim a, b, c, d
Dim dl&, i, j, n, k
dl = Feuil1.Range("a5").End(xlDown).Row
a = Feuil1.Range(Cells(4, 1), Cells(dl, 40))
n = 0
ReDim b(UBound(a), 6)
ReDim c(UBound(a), 6)
ReDim d(UBound(a), 6)
For j = 11 To 40
If CDate(a(1, j)) = Date Then
For i = 1 To dl - 5
If a(i, j) = 1 Then
Select Case a(i, 3)
Case Is < 5
n = n + 1
For k = 1 To 6
b(n, k) = a(i, k)
Next
Case Is >= 9
nn = nn + 1
For k = 1 To 6
c(nn, k) = a(i, k)
Next
Case Else
nnn = nnn + 1
For k = 1 To 6
d(nnn, k) = a(i, k)
Next
End Select
End If
Next
End If
Next
With Feuil2
.Cells.Delete
.[a1:f1] = Feuil1.[a4:f4].Value2
.[a2].Resize(UBound(b), 6) = b
End With
With Feuil6
.Cells.Delete
.[a1:f1] = Feuil1.[a4:f4].Value2
.[a2].Resize(UBound(d), 6) = d
End With
With Feuil7
.Cells.Delete
.[a1:f1] = Feuil1.[a4:f4].Value2
.[a2].Resize(UBound(c), 6) = c
End With
Feuil2.Activate
End Sub