Précédent   Forum des professionnels en informatique > Logiciels > Microsoft Office > Excel > Macros et VBA Excel
Macros et VBA Excel Vos questions relatives aux macros Excel, à l'utilisation de VBA et à l'automatisation de vos classeurs Excel.
Partagez cette discussion sur d'autres réseaux sociaux : Viadeo Twitter Google Facebook Digg Delicious MySpace Yahoo
Réponse Proposer ce sujet en actualité
 
Outils de la discussion
Publicité
Vieux 07/02/2010, 12h14   #1
Candidat au titre de Membre du Club
 
Date d'inscription: janvier 2010
Messages: 23
Par défaut Récupération de données sur plusieurs fichiers

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.
"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

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
jose_67 est déconnecté   Envoyer un message privé Réponse avec citation
Vieux 07/02/2010, 12h36   #2
Expert Confirmé
 
Date d'inscription: juillet 2007
Localisation: Loire Atlantique (44)
Âge: 54
Messages: 1 863
Par défaut

Salut jose_67 et le forum
Nouveauté sur le forum : il existe des balises pour le code!!!!!
Peut-être
Code :
        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+
__________________
La qualité et la précision de la réponse sont proportionnelles à celles de la question.
Gorfael est déconnecté   Envoyer un message privé Réponse avec citation
Vieux 07/02/2010, 15h32   #3
Candidat au titre de Membre du Club
 
Date d'inscription: janvier 2010
Messages: 23
Par défaut

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 :
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
 
jose_67 est déconnecté   Envoyer un message privé Réponse avec citation
Vieux 07/02/2010, 16h40   #4
Membre Expert
 
Date d'inscription: juillet 2008
Messages: 1 253
Par défaut

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

en plus, tu peux simplifier la partie concernée par ceci
Code :
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
__________________
Cordialement.
mercatog est déconnecté   Envoyer un message privé Réponse avec citation
Vieux 08/02/2010, 11h01   #5
Candidat au titre de Membre du Club
 
Date d'inscription: janvier 2010
Messages: 23
Par défaut

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 :
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é
jose_67 est déconnecté   Envoyer un message privé Réponse avec citation
Vieux 08/02/2010, 18h06   #6
Membre Expert
 
Date d'inscription: juillet 2008
Messages: 1 253
Par défaut

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 :
            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
 
__________________
Cordialement.
mercatog est déconnecté   Envoyer un message privé Réponse avec citation
Vieux 08/02/2010, 20h48   #7
Candidat au titre de Membre du Club
 
Date d'inscription: janvier 2010
Messages: 23
Par défaut

Re bonjour effectivement il fallait comprendre colonne 2 et non 3 pour le reste c'est super çà marche super.
Encore merci.
jose_67 est déconnecté   Envoyer un message privé Réponse avec citation
NEWS EXCELF.A.Q EXCELTUTORIELS EXCELSOURCES EXCELOUTILS EXCELLIVRES EXCELOFFICE 2010

Réponse Proposer ce sujet en actualité

Précédent   Forum des professionnels en informatique > Logiciels > Microsoft Office > Excel > Macros et VBA Excel



Outils de la discussion

Règles de messages
Vous ne pouvez pas créer de nouvelles discussions
Vous ne pouvez pas envoyer des réponses
Vous ne pouvez pas envoyer des pièces jointes
Vous ne pouvez pas modifier vos messages

Les balises BB sont activées : oui
Les smileys sont activés : oui
La balise [IMG] est activée : oui
Le code HTML peut être employé : non
Trackbacks are non
Pingbacks are non
Refbacks are non



Fuseau horaire GMT +1. Il est actuellement 10h15.


Vos questions techniques : forum d'entraide Excel - Publiez vos articles, tutoriels et cours
et rejoignez-nous dans l'équipe de rédaction du club d'entraide des développeurs francophones
Nous contacter - Hébergement - Participez - Copyright © 2000-2010 www.developpez.com - Legal informations.