1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
| Option Explicit
Option Base 1
Sub Extraction_Hebdo()
Dim Cel As Range, xchoixnosem, semExist As Range
Dim i As Long, xdlgn As Long, xdlgn1 As Long
Dim wb As Workbook
Application.ScreenUpdating = False
' Contrôle de la saisie
xchoixnosem = InputBox(Prompt:="Indiquez le numéro de semaine (chiffre compris entre 1 et 52), puis Valider par la touche Entrée du clavier ?", Title:="Choix de la semaine")
' Si bouton Annuler
If xchoixnosem = "" Then Exit Sub
If xchoixnosem < 1 Or xchoixnosem > 52 Then
MsgBox "Le numéro de la semaine doit être un chiffre compris entre 1 et 52.", vbCritical, "Choix de la semaine"
Application.ScreenUpdating = True
Exit Sub
End If
' Vérification si n° de semaine existe
Set semExist = Workbooks("MC_Plastique.xlsm").Sheets("Synthese").Range("B:B").Find(xchoixnosem, LookIn:=xlValues, lookat:=xlWhole)
If semExist Is Nothing Then
MsgBox "N° de semaine non trouvé!", vbOKOnly + vbExclamation, "SEMAINE NON RENSEIGNÉE"
Exit Sub
End If
' Extraction des données
With Feuil2
.Range("A2:S" & Rows.Count).ClearContents
.Activate
End With
For Each wb In Workbooks
If Not wb Is ThisWorkbook Then
With wb.Sheets("Synthese")
xdlgn = .Range("B" & Rows.Count).End(xlUp).Row
For Each Cel In .Range("B6:B" & xdlgn)
If Cel.Value Like xchoixnosem Then
xdlgn1 = ThisWorkbook.Sheets("Synthese").Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 1 To 19
ThisWorkbook.Sheets("Synthese").Cells(xdlgn1, i) = .Cells(Cel.Row, i)
Next
ThisWorkbook.Sheets("Synthese").Cells(xdlgn1, 20) = wb.Name
End If
Next
End With
End If
Next |
Partager