Sub Extract_Sem()
Dim DateCherche, i&, J&, K&, L&
Dim TabReport(1 To 7, 1 To 32)
K = 0
DateCherche = InputBox("Veuillez saisir le numéro de semaine")
If DateCherche = 0 Or DateCherche = "" Then Exit Sub
If DateCherche < 1 Or DateCherche > 55 Then
MsgBox "Merci de saisir un numéro de semaine valide"
Exit Sub
End If
With ActiveSheet
For i = 3 To .Cells(Rows.Count, 2).End(xlUp).Row
If Format(.Cells(i, 2), "WW", vbFirstFourDays) = DateCherche Then
K = K + 1
For J = 1 To 32
TabReport(K, J) = .Cells(i, J)
Next J
End If
Next i
End With
If K = 0 Then
MsgBox "Cette semaine n'est pas présente sur cette feuille"
Else
Sheets("semaine").Cells(6, 2).Resize(7, 32) = TabReport
MsgBox "Semaine copiée"
End If
End Sub
Sub Extract_Sem()
Dim DateCherche, i&, J&, K&, L&
Dim TabReport(1 To 7, 1 To 31)
K = 0
DateCherche = InputBox("Veuillez saisir le numéro de semaine")
If DateCherche = 0 Or DateCherche = "" Then Exit Sub
If DateCherche < 1 Or DateCherche > 55 Then
MsgBox "Merci de saisir un numéro de semaine valide"
Exit Sub
End If
With ActiveSheet
For i = 3 To .Cells(Rows.Count, 2).End(xlUp).Row
If Format(DateSerial(Range("noan"), .Cells(2, 1), .Cells(i, 3)), "WW", vbMonday, vbFirstFourDays) = DateCherche Then
K = K + 1
For J = 1 To 31
TabReport(K, J) = .Cells(i, J + 2)
Next J
End If
Next i
End With
If K = 0 Then
MsgBox "Cette semaine n'est pas présente sur cette feuille"
Else
Sheets("semaine").Cells(6, 2).Resize(7, 31) = TabReport
MsgBox "Semaine copiée"
End If
End Sub
Sub Extract_Sem()
Dim DateCherche, i&, J&, K&, L&, NbrCol&, NumJour%, FrstCol&
Dim Ddate As Date, TabReport()
K = 0: NumJour = 0
NbrCol = 31 'Nombre de colonnes à copier
ReDim TabReport(1 To 7, 1 To NbrCol)
DateCherche = InputBox("Veuillez saisir le numéro de semaine")
If DateCherche = 0 Or DateCherche = "" Then Exit Sub
If DateCherche < 1 Or DateCherche > 53 Or Not IsNumeric(DateCherche) Then
MsgBox "Merci de saisir un numéro de semaine valide"
Exit Sub
End If
With ActiveSheet
For i = 3 To .Cells(Rows.Count, 2).End(xlUp).Row
Ddate = DateSerial(Range("noan"), .Cells(2, 1), .Cells(i, 3))
If Format(Ddate, "WW", vbMonday, vbFirstFourDays) = DateCherche Then
If NumJour = 0 Then NumJour = Weekday(Ddate, vbMonday)
K = K + 1
For J = 1 To NbrCol
TabReport(K, J) = .Cells(i, J + 2)
Next J
End If
Next i
End With
With Sheets("semaine")
.Range(.Cells(6, 2), .Cells(12, NbrCol)).ClearContents
If K = 0 Then
MsgBox "Cette semaine n'est pas présente sur cette feuille"
Else
.Cells(NumJour + 5, 2).Resize(K, NbrCol) = TabReport
MsgBox "Semaine copiée"
End If
'.Activate
End With
End Sub