Extraction données d'un autre fichier excel

[applemilk]

Bonjour,

J'ai créé une macro liée à un bouton qui sert à aller chercher des infos dans un fichier excel pour les mettre dans mon tableau. Ca ne fonctionne pas pour le moment, je ne comprends pas pourquoi:

Le button1 sert au mot de passe et le button2 sert à aller chercher dans mes répertoires le dossier que je veux.

La macro trouve effectivement bien les fichiers que je veux (on voit les fichiers s'ouvrir et se refermer un par un) mais lorsqu'elle se termine, rien ne s'est passé dans mon tableau, la colonne 3 est toujours vide.

Voici le texte:


Private Sub CommandButton1_Click()
racine = ChoixDossier()
UserForm4.Rep = racine
End Sub

Private Sub CommandButton2_Click()
UserForm4.Hide
Dim i As Long
Dim Recherche As ClFileSearch.ClasseFileSearch

Z = Feuil4.Cells(5, 8)
Set Recherche = ClFileSearch.Nouvelle_Recherche
'Set fichcherche = Application.FileSearch

With Recherche


.FolderPath = UserForm4.Rep 'Changer le chemin
.SubFolders = UserForm4.CheckBox1.Value
.Extension = "*.xls"

If .Execute > 0 Then
MsgBox .FoundFilesCount & " Fichiers(s) a (ont) été trouvé(s)."
Application.ScreenUpdating = False


'lignevide
For xx = 25 To 65000
If Feuil4.Cells(xx, 2) = "" Then
Index22 = xx - 1
Exit For
End If
Next xx



For i = 1 To .FoundFilesCount
'MsgBox .Files(i).strNom
NOMFICH = .Files(i).strChemin & "\" & .Files(i).strNom
Set xls = Workbooks.Open(NOMFICH, 0, True)
On Error Resume Next

xls.Worksheets("BASE LOCAUX").Activate

'indexfin
For ty = 7 To 65000
If xls.Worksheets("BASE LOCAUX").Cells(ty, 5) = "" Then
indexfin = ty - 1
Exit For
End If
Next ty

'Coûts standards
If xls.Worksheets("BASE LOCAUX").Cells(indexfin, 150) <> 0 Then

For yt = 7 To indexfin
If (xls.Worksheets("BASE LOCAUX").Cells(yt, 3) = Feuil4.Cells(Index22,2)) Then
Feuil4.Cells(Index22, 3) = xls.Worksheets("BASE LOCAUX").Cells(yt, 44)End If
Next yt

End If


xls.Close savechanges:=False

Set xls = Nothing

Next i
Feuil4.Cells(5, 8) = Z
Application.ScreenUpdating = True

Else
MsgBox ("Pas de fichiers trouvés")


End If
End With
End Sub


Voyez-vous l'erreur?
Merci beaucoup d'avance!

 

[Pierrot93]

Re : Extraction données d'un autre fichier excel

Bonjour,

A priori, la première erreur est là :

On Error Resume Next

cette ligne de code permet en cas d'erreur, de ne pas s'arrêter sur la ligne ayant provoquée cette erreur, mais de poursuivre l'exécution du code à partir de l'instruction suivante.... ce qui, bien évidemment, peut donner un résultat erroné lorsque l'erreur n'est pas gérée...

commence par supprimer cette ligne, et exécute ton code pas à pas (utilisation de la touche F8 dans l'éditeur vba), pour voir exactement comment les instructions sont exécutées...

bonne journée
@+

 

[applemilk]

Re : Extraction données d'un autre fichier excel

Bonjour,

Merci pour votre réponse,

j'ai bien enlevé : "On Error Resume Next"

En faisant la manip' avec F8, excel m'affiche un message d' "erreur '5' Argument ou appel de procédure incorrect "
juste après le code if . execute>0 then (dans le fichier clFileSearch)

J'ai un code ClFileSearch déjà pré écrit dans excel, qui a du être intégré par un collègue qui l'a pris sur internet je pense.



Ci après en rouge, l'endroit où la macro affiche le message d'erreur:

Option Explicit
Option Compare Text
Option Base 1


'-------------------------------------------------

'Module de classe ClasseFileSearch pour Excel 2007
'SilkyRoad
'http://silkyroad.developpez.com/
'
'
'Mise à jour le 01.07.2007

'-------------------------------------------------


'La procédure recherche des fichiers en fonction des critères
'spécifiés et renvoie dans un tableau :

'Le nom des fichiers
'Le chemin
'La taille des fichers (en octets)
'La date de création
'La date de dernière modification
'Le type de fichier)


'-------------------------------------------------


'Enumération pour les options de tri
Public Enum Sort_By
Sort_None
sort_Name
sort_Path
sort_Size
sort_DateCreated
sort_LastModified
sort_Type
End Enum


Dim TabFiles() As InfosResultFichiers
Dim DirectoryPath As String
Dim lngFoundFilesCount As Long
Dim boolSousRep As Boolean
Dim strExtens As String
Dim optionSortBy As Long



'Propriété pour le répertoire de recherche
Public Property Let FolderPath(strFolderPath As String)
DirectoryPath = strFolderPath
End Property


'Propriété pour rechercher dans les sous dossiers
Public Property Let SubFolders(boolSubFolders As Boolean)
boolSousRep = boolSubFolders
End Property


'Propriété pour lister les fichiers correspondants à la requête
Public Property Get Files(Idx As Long) As InfosResultFichiers
Files = TabFiles(Idx)
End Property


'Propriété pour l'extension des fichiers à rechercher
Public Property Let Extension(strExtension As String)
strExtens = strExtension
End Property


'Propriété pour compte le nombre de fichiers
Public Property Get FoundFilesCount() As Long
FoundFilesCount = lngFoundFilesCount
End Property


'Propriété pour l'option de tri
Public Property Let SortBy(lngSortBy As Sort_By)
optionSortBy = lngSortBy
End Property


'Fonction d'exécution
Public Function Execute() As Long
'Lance la recherche
ListeFichiers DirectoryPath

'Vérifie que des fichiers ont été trouvés et qu'une option de tri a
'été spécifié avant de lancer la procédure de tri.
If lngFoundFilesCount > 1 And optionSortBy <> Sort_By.Sort_None Then _
FonctionTri optionSortBy

Execute = lngFoundFilesCount
End Function



'Procédure pour lister les fichiers
Private Sub ListeFichiers(strFolderName As String)
Dim Fso As Object
Dim NomDossier As Object, SousDossier As Object
Dim objFichier As Object

On Error GoTo Fin

La macro s'arrête ici, je n'arrive pas à comprendre pourquoi
'Vérifie si le dossier spécifié existe
If Dir(strFolderName, vbDirectory Or vbHidden Or vbSystem) = "" Then Exit Sub

Set Fso = CreateObject("Scripting.FileSystemObject")
Set NomDossier = Fso.GetFolder(strFolderName)


'Boucle sur les fichiers du répertoire
For Each objFichier In NomDossier.Files

'Vérifie l'extension du fichier
If objFichier.Name Like strExtens Or strExtens = "" Then

'Redimensionne le tableau pour ajouter un nouvel élément
lngFoundFilesCount = lngFoundFilesCount + 1
ReDim Preserve TabFiles(lngFoundFilesCount)

'Nom fichier
TabFiles(lngFoundFilesCount).strFileName = objFichier.Name
'Répertoire
TabFiles(lngFoundFilesCount).strPathName = objFichier.ParentFolder
'Taille du fichier (en octets)
TabFiles(lngFoundFilesCount).lngSize = objFichier.Size
'Date de création
TabFiles(lngFoundFilesCount).DateCreated = objFichier.DateCreated
'Date de création ou dernière modification
TabFiles(lngFoundFilesCount).DateLastModified = objFichier.DateLastModified
'Type de fichier
TabFiles(lngFoundFilesCount).strFileType = objFichier.Type
End If
Next objFichier


'Boucle récursive:
'(Si l'option de recherche dans les sous répertoires a été spécifiée)
If boolSousRep Then
For Each SousDossier In NomDossier.SubFolders
ListeFichiers SousDossier.Path
Next SousDossier
End If


Exit Sub:

Fin:
MsgBox "Erreur '" & Err.Number & "'" & vbCrLf & vbCrLf & _
Err.Description, vbInformationEnd Sub



'Procédure de tri (reste à améliorer).
Private Sub FonctionTri(optionSortBy As Sort_By)
Dim i As Long, j As Long, k As Long
Dim ValTemp As Variant

'Vérifie quel champ du tableau doit être trié
Select Case optionSortBy

Etc.

Merci encore pour votre aide!
Je ne connaissais pas le bouton F8, qui s'avère être très utile!

 

[Pierrot93]

Re : Extraction données d'un autre fichier excel

Re,

quand tu dis :

La macro s'arrête ici, je n'arrive pas à comprendre pourquoi

ca veut dire quoi ? message d'erreur ou l'instruction "exit sub" est exécutée ? si c'est le cas, c'est qu'il n'y a pas de fichier répondant au critère.

A noter, jamais vu l'opérateur "or" employé avec la fonction "dir" ...

If Dir(strFolderName, vbDirectory Or vbHidden Or vbSystem) = "" Then Exit Sub

A priori, ça passe tout de même chez moi....

bon parès midi
@+

 

[applemilk]

Re : Extraction données d'un autre fichier excel

Re,

J'ai quelque peu avancé, la macro ne m'affiche plus de message d'erreur à cet endroit mais elle ignore une de mes conditions un peu plus loin

Je pense que je suis à un fil de réussir mais un truc me bloque encore.


Private Sub CommandButton1_Click()
racine = ChoixDossier()
UserForm4.Rep = racine
End Sub

Private Sub CommandButton2_Click()
UserForm4.Hide
Dim i As Long
Dim Recherche As ClFileSearch.ClasseFileSearch

Z = Feuil4.Cells(5, 7)
Set Recherche = ClFileSearch.Nouvelle_Recherche
'Set fichcherche = Application.FileSearch

With Recherche


.FolderPath = UserForm4.Rep 'Changer le chemin
.SubFolders = UserForm4.CheckBox1.Value
.Extension = "*.xls"

If .Execute > 0 Then
MsgBox .FoundFilesCount & " Fichiers(s) a (ont) été trouvé(s)."

Application.ScreenUpdating = False

'ligne vide
For xx = 25 To 65000
If Feuil4.Cells(xx, 1) = "" Then
Index22 = xx - 1
Exit For
End If
Next xx


For i = 1 To .FoundFilesCount
'MsgBox .Files().strNom
Fichier = .Files(i).strChemin & "\" & .Files(i).strNom
Set xls = Workbooks.Open(Fichier, 0, True)


xls.Worksheets("BASE LOCAUX").Activate

'indexfin
For ty = 7 To 65000
If xls.Worksheets("BASE LOCAUX").Cells(ty, 3) = "" Then
indexfin = ty - 1
Exit For
End If
Next ty

'Coûts standards
For yt = 7 To indexfin
If (xls.Worksheets("BASE LOCAUX").Cells(yt, 3) = Feuil4.Cells(Z, 2))) Then
Feuil4.Cells(Z, 3) = xls.Worksheets("BASE LOCAUX").Cells(yt, 44)

Je sais que c'est ça qui est faux mais je ne sais pas comment l'écrire différement.

Z = Z + 1
Next yt
Next i

xls.Worksheets("BASE LOCAUX").Activate
xls.Close savechanges:=False

Set xls = Nothing


Feuil4.Cells(5, 7) = Z
Application.ScreenUpdating = True

Else
MsgBox ("Pas de fichiers trouvés")



End If
End With
End Sub


Private Sub Rep_Change()

End Sub

Private Sub UserForm_Click()

End Sub


Merci de votre aide!

 

[Pierrot93]

Re : Extraction données d'un autre fichier excel

Re,

pas facile de lire un code ainsi.... lorsque tu écris un message, il y a des icones juste au dessus, en l'occurence le # qui te permet d'insérer un code, celui est beaucoup plus lisible... exemple ci-dessous :

Dim i As Long, j As Long
For i = 1 To 10
    For j = 1 To 5
        If Cells(i, j) = Cells(i, j + 1) Then
            Cells(i, j) = ""
        End If
    Next j
Next i

sinon pour ton problème, comme ça, vois pas trop... peut être un bout de fichier pour voir les données traitées...

@+

 

[applemilk]

Re : Extraction données d'un autre fichier excel

Ah oui effectivement... désolée, en+ c'est écrit dans la charte.


Tu trouveras dans le fichier joint les deux onglets (en realité deux fichiers différents) dont je me sers pour la macro.

En fait, je voudrais que la macro fasse une recherche v:
si BASE LOCAUX").Cells(yt, 3) = Feuil4.Cells(Z, 2) (ce sont des noms de famille)
alors afficher numéro en colonne 44 s'y rapportant.

Et s'il ne trouve pas le nom de famille dans Feuil4.Cells(Z, 2)
alors il va chercher dans un autre dossier.

Je continue à chercher sur internet... je débute... désolée
Merci et bonne soirée

 

[Pierrot93]

Re : Extraction données d'un autre fichier excel

Re,

je ne peux ouvrir ton fichier, il semble endomagé...

 

[applemilk]

Re : Extraction données d'un autre fichier excel

Ah mince, je te le renverrai demain,

Mais avant, j'ai trouvé une réponse que tu avais apporté sur un autre post concernant le même sujet.
J'essaierai ton code et reviendrai vers toi si je n'y arrive pas..

Merci et bonne soirée

 

[applemilk]

Re : Extraction données d'un autre fichier excel

Bonjour,

Bon bah ca fait 1h que j'essaye main en vain...
j'ai le message d'erreur "impossible de lire la propriété VLookup de la classe Worksheetfunction" et je n'arrive pas à résoude le pb.

Je l'ai écrit comme ca

Private Sub CheckBox1_Click()

End Sub

Private Sub CommandButton1_Click()
racine = ChoixDossier()
UserForm4.Rep = racine
End Sub

Private Sub CommandButton2_Click()
UserForm4.Hide
Dim i As Long
Dim Recherche As ClFileSearch.ClasseFileSearch
 
 Z = Feuil4.Cells(5, 7)
Set Recherche = ClFileSearch.Nouvelle_Recherche
'Set fichcherche = Application.FileSearch

With Recherche


.FolderPath = UserForm4.Rep 'Changer le chemin
.SubFolders = UserForm4.CheckBox1.Value
.Extension = "*.xls"

If .Execute > 0 Then
MsgBox .FoundFilesCount & " Fichiers(s) a (ont) été trouvé(s)."

Application.ScreenUpdating = False

'ligne vide
For xx = 25 To 65000
If Feuil4.Cells(xx, 1) = "" Then
Index22 = xx - 1
Exit For
End If
Next xx


For i = 1 To .FoundFilesCount
'MsgBox .Files().strNom
Fichier = .Files(i).strChemin & "\" & .Files(i).strNom
Set xls = Workbooks.Open(Fichier, 0, True)


xls.Worksheets("BASE LOCAUX").Activate

'indexfin
For ty = 7 To 65000
If xls.Worksheets("BASE LOCAUX").Cells(ty, 3) = "" Then
indexfin = ty - 1
Exit For
End If
Next ty

'Coûts standards
For l = 26 To Range("B65000").End(xlUp).Row
If Cells(l, 2) <> "" Then
If WorksheetFunction.CountIf(Range("C7:AS500"), Cells(l, 3)) > 0 Then
Cells(l, 2) = WorksheetFunction.VLookup(Cells(indexfin, 150), Range("$C$7:$AS$500"), 42, 0)
Else
Cells(l, 150) = "Non trouvé"
End If
End If
Next


Next i

xls.Worksheets("BASE LOCAUX").Activate
xls.Close savechanges:=False

Set xls = Nothing
        
Feuil4.Cells(5, 7) = Z
Application.ScreenUpdating = True

Else
MsgBox ("Pas de fichiers trouvés")

End If
End With
End Sub

Private Sub Rep_Change()

End Sub

Private Sub UserForm_Click()

End Sub