Discussion :

[parmi]

Est-ce que c'est possible pour toi de joindre un fichier de données (sans données confidentielles) pour qu'on puisse bien voir la structure que tu nous expliques, mais qui semble un peu compliquée à suivre...?

[LANGAZOU]

Je ne suis pas au boulot pour vous envoyer le fichier exact donc j'ai fait un petit exemple (ci-joint) pour vous faire comprendre le principe.

Exemple 1.xlsxExemple 2.xlsxRésultat.xlsx

- Les données que je voudrais récupérer existent dans la 1ère et 2ème PJ ("Exemple" ) sur les feuilles "1", "2" et "3" (en jaune).
- la 3ème pj ("Résultat") résume toutes les données que j'ai récupéré des trois feuilles (Exemple 1 et 2 )" et représente le format requis. A partir de ce principe , et pour chaque classeur on récupère les mêmes données sur les 3 feuilles (à l'aide du macro de kiko29) et les insérer toutes dans l'ordre décroissant et selon le format déjà mentionné.

j’espère que j'étais suffisamment clair. mon but c'est de savoir comment extraire des données à partir des cellules précises et les insérer toutes dans un ordre

Merci beaucoup pour votre intervention.

[parmi]

Je te mets ma façon de procéder qui est pas mal plus simple que l'autre programme que kiki29 t'a suggéré.
Je n'ai pas le temps de tout regarder ce programme et essayer de le comprendre.

Voici donc la façon que j'utiliserais
Copie ce code dans un module de ton classeur Résultats et change le chemin si nécessaire.
Assure-toi que l'onglet où tu veux mettre les données se nomme bien Feuil1, sinon change le nom partout dans le code pour le bon.

Au départ, j'efface les données présentes.
Si tu veux les conserver, enlève la ligne.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
51
52
53
54
55
56
57
58
59
60
61
62
Sub SearchFiles()
    Dim nbLignes As Long
 
    nbLignes = Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row
 
    'Efface les données existantes avant de copier
    'Effacer cette ligne si ce n'est pas nécessaire
    Sheets("Feuil1").Range("A2:A" & nbLignes).EntireRow.Delete
 
    ImportFiles "c:\Desktop\2015\"   'Changer au besoin
 
    MsgBox "Terminé"
End Sub
 
Sub ImportFiles(varPath As Variant)
    Dim nbLignes As Long
    Dim varFile As Variant
    Dim objColl As Collection
 
    On Error GoTo Erreur
 
    Set objColl = New Collection
 
    If Right(varPath, 1) <> "\" Then varPath = varPath & "\"
 
    varFile = Dir(varPath, vbDirectory + vbArchive)
    Do While varFile <> ""
        'Stocke le répertoire
        If GetAttr(varPath & varFile) = vbDirectory Then
            If Left(varFile, 1) <> "." Then
                objColl.Add varPath & varFile
            End If
 
        'Travailler avec le fichier
        ElseIf LCase(Right(varFile, 3)) = "xls" Or LCase(Right(varFile, 4)) = "xlsx" Then
            'Détermine la première ligne vide du classeur Résultats
            nbLignes = ThisWorkbook.Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row + 1
 
            'Ouvrir le fichier, copier les données et le fermer
            Workbooks.Open varPath & varFile, , True
 
            ActiveWorkbook.Sheets(1).Range("A2").Copy ThisWorkbook.Sheets("Feuil1").Range("A" & nbLignes)
            ActiveWorkbook.Sheets(1).Range("C5").Copy ThisWorkbook.Sheets("Feuil1").Range("B" & nbLignes)
            ActiveWorkbook.Sheets(2).Range("B4").Copy ThisWorkbook.Sheets("Feuil1").Range("C" & nbLignes)
            ActiveWorkbook.Sheets(3).Range("B4").Copy ThisWorkbook.Sheets("Feuil1").Range("D" & nbLignes)
 
            ActiveWorkbook.Close False
        End If
        varFile = Dir
    Loop
 
    For Each varFile In objColl
        ImportFiles varFile
    Next
 
    Set objColl = Nothing
 
    Exit Sub
 
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
End Sub

[LANGAZOU]

Bonjour,

ça marche très bien et c'est facile à modifier ! Merci beaucoup.
juste un petit truc : après avoir tester et ajouter plusieurs données , j'ai voulu faire le tri des lignes selon la date de la plus ancienne au plus récente mais ça n'a pas marché .

ci dessous le code que j'ai ajouté à la fin de ton code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    Range("A2").Select
    ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

[parmi]

La ligne avec le .Clear cause un problème.

Essaie comme ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Tri()
    Dim nbLignes As Long
 
    nbLignes = Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row
 
    Sheets("Feuil1").Sort.SortFields.Add Key:=Range("A2:A" & nbLignes), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Feuil1").Sort
        .SetRange Range("A1:D" & nbLignes)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[LANGAZOU]

Merci pour ton aide précieuse.