Extraction de certaines cellules sur plusieurs tableaux Excel avec condition

Re : Extraction de certaines cellules sur plusieurs tableaux Excel avec condition

Rebonjour,
Je vois que personne est inspiré par mon probléme... J'ai essayé de concocter un code dites moi ce que vous en pensez ca ne marche pas 🙁 J'ai besoin d'aide !!
Function GetFileName(FullPath As String)

Dim StrFind As String
Do Until Left(StrFind, 1) = "\"
iCount = iCount + 1
StrFind = Right(FullPath, iCount)
Loop
GetFileName = Right(StrFind, Len(StrFind) - 1)
End Function
Sub Extraction()
Dim MyPath
Dim FilesInPath As String
Dim MyFiles() As String
Dim fileName As String
Dim file As Object
Dim x As Integer



MyPath = "U:\Classeurs-PV\"

'Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "Pas de fichiers trouvés!"
Exit Sub
End If

x = 0



Do While FilesInPath <> “”
fileName = GetFileName(FilesInPath)
For Each FileItem In MyPath
If fileName Like "?*.xls" And ((Left(Right(fileName, 9), 2) * 1 <= Sheets("Feuil1").Range("B2").Value) Or (Left(Right(fileName, 9), 2) * 1 >= Sheets("Feuil1").Range("C2").Value) And (Left(Right(fileName, 7), 2) * 1 <= Sheets("Feuil1").Range("D2").Value) Or (Left(Right(fileName, 7), 2) * 1 >= Sheets("Feuil1").Range("E2").Value)) Then

MsgBox "Pas de rapports correspondants à cet interval là!"
Exit Sub

End If
x = x + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop

If x > 0 Then

For x = LBound(MyFiles) To UBound(MyFiles)
ActiveCell = "A13"
Range(ActiveCell.Offset(0, 4).Offset(20, 0)).Select
Range(ActiveCell.offset(0,5),(ActiveCell.Offset(0,7).Offset(20,0)).select
Range(Activecell.Offset(0,13),(ActiveCell.Offset((0,10).offset(20,0)).select

Selection.Copy
Sheets("Récapitulatif").Select
Range("B6").Select
ActiveSheet.Paste

End If




End Sub
Merci en avance pour votre aide 🙂