[XL-2007] Récupération de données sur plusieurs fichiers [Résolu]

[jose_67]

Bonjour à tous ,
Voici mon problème
Je souhaiterais récupérer des données sur plusieurs fichiers Xls pour les compiler sur un fichier Xls unique.
Je bloque au niveau de la boucle dans les fichiers Xls de recupération des données.

Code :

If Ws.Cells(ligne, 1).Text = Wb.Worksheets(1)(ligne, 1) Then

J'ai un message d'erreur

"erreur d'exécution '438':
Propriété ou méthode non gérée par cet objet

voici mon code

Code :

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
Sub recherche()
 
Dim Repertoire As String, Fichier As String
Dim Wb As Workbook
Dim Ws As Worksheet
 
Application.ScreenUpdating = False
 
'Définit la Première feuille du classeur contenant cette macro
'(pour recevoir les donnée extraites dans les autres classeurs).
Set Ws = ThisWorkbook.Worksheets(1)
 
'Définit le répertoire de recherche
Repertoire = "D:\Documents\Dossier D\TM \"
'Spécifie la recherche pour le fichiers .xls
Fichier = Dir(Repertoire & "*.xls")
 
'Boucle sur les fichiers du répertoire
Do While Fichier <> ""
    'Vérifie que le nom du classeur est différent du classeur
    'contenant cette macro (dans le cas ou il serait placé dans le même répertoire).
    If ThisWorkbook.Name <> Fichier Then
        'Ouvre chaque classeur
        Set Wb = Workbooks.Open(Repertoire & Fichier)
 
      For ligne = 5 To 8
    If Ws.Cells(ligne, 1).Text = Wb.Worksheets(1)(ligne, 1) Then
Ws.Cells(ligne, 2) = Wb.Worksheets(1)(ligne, 2)
End If
Next
 
        'Referme le classeur
        Wb.Close False
    End If
 
    Fichier = Dir
Loop
 
Application.ScreenUpdating = True
MsgBox "Terminé"
 
End Sub

Merci

[Gorfael]

Salut jose_67 et le forum
Nouveauté sur le forum : il existe des balises pour le code!!!!!
Peut-être

Code :

1
2
3
4
        For ligne = 5 To 8
            If Ws.Cells(ligne, 1).Text = Wb.Worksheets(1).Cells(ligne, 1) Then _
                Ws.Cells(ligne, 2) = Wb.Worksheets(1).Cells(ligne, 2)
        Next

A+

[jose_67]

Merci pour les infos
Je viens d'adapter le code à mes besoins. Mais la marco est un peut trop long (à l'exécution) il faudrait que je limite la boucle à la dernière ligne renseigner pour aller plus vite dans la recherche
Comment faire pour remplacer
For i = 29 To 700 par (dernière ligne renseignée)
For j = 5 To 3000 par (dernière ligne renseignée)
I for 5 to (dernière ligne renseignée)
Et en plus je voudrais renvoyer le Nom du fichier en colonne 3 de mon fichier Ws

Code :

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
Dim Repertoire As String, Fichier As String
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i, j As Single
 
Application.ScreenUpdating = False
 
'Définit la Première feuille du classeur contenant cette macro
'(pour recevoir les donnée extraites dans les autres classeurs).
Set Ws = ThisWorkbook.Worksheets(2)
 
'Définit le répertoire de recherche
Repertoire = "D:\Documents\Dossier DM\TM\"
'Spécifie la recherche pour le fichiers .xls
Fichier = Dir(Repertoire & "*.xls")
 
'Boucle sur les fichiers du répertoire
Do While Fichier <> ""
    'Vérifie que le nom du classeur est différent du classeur
    'contenant cette macro (dans le cas ou il serait placé dans le même répertoire).
    If ThisWorkbook.Name <> Fichier Then
        'Ouvre chaque classeur
        Set Wb = Workbooks.Open(Repertoire & Fichier)
 
       For i = 29 To 700
       For j = 5 To 3000
            If Ws.Cells(i, 2).Text = Wb.Worksheets(2).Cells(j, 1) Then _
                Ws.Cells(i, 18).Value = Wb.Worksheets(2).Cells(j, 2)
 
 
        Next j
        Next i
 
 
 
        'Referme le classeur
        Wb.Close False
    End If
 
    Fichier = Dir
Loop
 
Application.ScreenUpdating = True
MsgBox "Terminé"
 
End Sub

[mercatog]

ci joint lien http://www.developpez.net/forums/d45...gnees-feuille/

en plus, tu peux simplifier la partie concernée par ceci

Code :

1
2
3
4
5
6
7
8
9
10
11
Dim c As Range
Dim LastLig1 As Long, LastLig2 As Long
 
LastLig1 = ws.Cells(Rows.Count, 2).End(xlUp).Row
LastLig2 = Wb.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
 
For i = 29 To LastLig1
    Set c = Wb.Worksheets(2).Range("A5:A" & LastLig2).Find(ws.Cells(i, 2).Text, LookIn:=xlValues, lookat:=xlWhole)
    If Not c Is Nothing Then ws.Cells(i, 18).Value = c.Offset(0, 1)
    Set c = Nothing
Next i

[jose_67]

Tous d'abords merci à "Gorfael" et "Mercatog" pour cette aide rapide et efficace ma macro fonctionne.
Je voudrais encore pouvoir mettre dans ma (colonne 3) le nom du fichier d'ou arrive les valeurs

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Set Wb = Workbooks.Open(Repertoire & Fichier)
      
       LastLig1 = Ws.Cells(Rows.Count, 1).End(xlUp).Row
        LastLig2 = Wb.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row

For i = 5 To LastLig2
            Set c = Wb.Worksheets(1).Range("B5:B" & LastLig2).Find(Ws.Cells(i, 1).Text, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then Ws.Cells(i, 3).Value = c.Offset(0, 16)
            Set c = Nothing
    'Ws.Cells(i, 3) = Fichier ???
        Next i
       
                
        
        Wb.Close False
    End If

Cordialement José

[mercatog]

bonjour, la 3ème colonne risque d'avoir 2 données, l'une effacera l'autre.
pour ta question, si tu veux le nom entier

Code :

1
2
3
4
5
6
            Set c = Wb.Worksheets(1).Range("B5:B" & LastLig2).Find(Ws.Cells(i, 1).Text, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then 
                 Ws.Cells(i, 3).Value = c.Offset(0, 16)
                 Ws.Cells(i, XX).Value = wb.fullname
             end if
            Set c = Nothing

[jose_67]

Re bonjour effectivement il fallait comprendre colonne 2 et non 3 pour le reste c'est super çà marche super.
Encore merci.