Extraction de certaines cellules sur plusieurs tableaux Excel avec condition

[Moroccankiss]

Bonjour,
Mon probléme est assez complexe de mon point de vue de trés (trés) débutant sur Excel. En effet je vouderais utiliser des macros pour aller chercher certaines cellules de certaines lignes ( donc avec condition) dans plusieurs fichiers excel (dont le nombre évolue de jour en jour... sans les ouvrir si c'est possible!!) et tout récapituler dans un tableau à part pour que je puisse analyser ces infos à travers des paretos dans un premier temps. Secondo je vouderais créer des fenetres qui vont me permettre de choisir des critéres ( Mois, Produit...) afin d'affiner mon analyse. J'espere que je me suis fait comprendre, J'ai énormement besoin d'aide je rame beaucoup et j'arrive pas à adapter les macros déja proposées sur ce site
Merci d'avance pour votre aide !!

Ps: j'ai joint le fichier de base et le fichier récapitulatif avec les infos qui m'interessent.

 

[Moroccankiss]

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