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