Macro listing fichiers présents dans un dossier

D

dj dim

XLDnaute Occasionnel
Bonjour à tous,

Je me permets de solliciter votre aide en tant que novice en vba.

J'ai modifié une macro récupérée sur le net dans le but de lister les fichiers disponibles dans un dossier.

Le nom des fichiers se présente toujours sous la forme :
N°xxx_Ulysse_2010(Moisxxx)_Clientxxx.xls

Le soucis c'est que je souhaite récupérer les infos figurant dans le nom du fichier et le répartir de la manière suivante :
A5 = N°xxx
B5 = Clientxxx
C5 = lien vers le fichier
D5 = Moisxxx
puis
A6 = N°xxx
B6 = Clientxxx
C6 = lien vers le fichier
D6 = Moisxxx
etc ...

Problème rencontré : le code fonctionne jusqu'à la ligne 12 puis m'informe d'un bug sur la ligne :
Code: 
Cells(i + 4, 1) = Mid(Chaine, 1, InStr(1, Chaine, "_Ulysse") - 1)

Vous trouverez ci-dessous le code que j'ai modifié.

Code: 
Sub Liste_des_fichiers()
'
' lien_hypertext_liste_fichiers Macro
'

Dim mess As String, mess2 As String, répertoire As String
mess = "\\Mariepierre\AAA_Tarifs Clients en vigueur\"
mess2 = "xls"
Application.ScreenUpdating = False
répertoire = Dir("\\Mariepierre\AAA_Tarifs Clients en vigueur\" & "*" & "xls", vbDirectory)
Do While répertoire <> ""
i = i + 1
Cells(i + 4, 3) = répertoire
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 3), Address:=mess & répertoire
répertoire = Dir
Loop
End Sub



Sub Num_Ulysse()
Dim mess As String, mess2 As String, Chaine As String
mess = "\\Mariepierre\AAA_Tarifs Clients en vigueur\"
mess2 = "xls"
Application.ScreenUpdating = False
Chaine = Dir("\\Mariepierre\AAA_Tarifs Clients en vigueur\" & "*" & "xls", vbDirectory)
Do While Chaine <> ""
i = i + 1
Cells(i + 4, 3) = Chaine
Cells(i + 4, 1) = Mid(Chaine, 1, InStr(1, Chaine, "_Ulysse") - 1)
Cells(i + 4, 2) = Mid(Chaine, InStr(Chaine, ")_") + 2)
Chaine = Dir
Loop
End Sub

Merci d'avance pour votre aide.
 
Trier par date Trier par votes
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro listing fichiers présents dans un dossier

Bonjour dj dim,
Une proposition en une seule macro (A tester avec la liste complète des fichiers...)
Code: 
[COLOR=blue]Sub[/COLOR] Num_Ulysse_2()
[COLOR=blue]Dim[/COLOR] mess [COLOR=blue]As String[/COLOR], mess2 [COLOR=blue]As String[/COLOR], Chaine [COLOR=blue]As String[/COLOR], i [COLOR=blue]As Long[/COLOR], Var [COLOR=blue]As Variant[/COLOR]
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
i = 4
mess = "[URL="file://\\Mariepierre\AAA_Tarifs"]\\Mariepierre\AAA_Tarifs[/URL] Clients en vigueur\"
mess2 = ".xls"
Chaine = Dir(mess & "*" & mess2)
[COLOR=blue]With[/COLOR] Sheets("Feuil1")
    [COLOR=blue]Do While[/COLOR] Chaine <> ""
        i = i + 1
        Var = Split(Chaine, "_")
        .Cells(i, 1) = Var([COLOR=blue]LBound[/COLOR](Var))
        .Cells(i, 2) = Mid(Var([COLOR=blue]UBound[/COLOR](Var)), 1, Len(Var([COLOR=blue]UBound[/COLOR](Var))) - 4)
        .Cells(i, 3).Value = Chaine
        .Hyperlinks.Add Anchor:=Cells(i, 3), Address:=mess & Chaine
        .Cells(i, 4) = Mid(Chaine, InStr(Chaine, "(") + 1, InStr(Chaine, ")_") - 2 - InStr(Chaine, "(") + 1)
        Chaine = Dir
    [COLOR=blue]Loop[/COLOR]
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Cordialement
 
Vote positif 0 Vote négatif
D

dj dim

XLDnaute Occasionnel
Re : Macro listing fichiers présents dans un dossier

Salut Efgé,

Merci beaucoup pour ta réponse, j'ai juste modifié le nom de la feuille suite bug et tout maintenant tout fonctionne.

1000 merci pour ton aide et ta réactivité ! :)
 
Vote positif 0 Vote négatif
D

dj dim

XLDnaute Occasionnel
Re : Macro listing fichiers présents dans un dossier

Bonjour à tous,

Je me permets de solliciter à nouveau votre aide car j'ai un problème avec le code qui marchait apparrement l'autre jour.

Voici le code :

Code: 
Sub Num_Ulysse_2()
Dim mess As String, mess2 As String, Chaine As String, i As Long, Var As Variant
Application.ScreenUpdating = False
i = 4
mess = "\\Mariepierre\AAA_Tarifs Clients en vigueur\"
mess2 = ".xls"
Chaine = Dir(mess & "*" & mess2)
With Sheets("Tarifs")
    Do While Chaine <> ""
        i = i + 1
        Var = Split(Chaine, "_")
        .Cells(i, 1) = Var(LBound(Var))
        .Cells(i, 2) = Mid(Var(UBound(Var)), 1, Len(Var(UBound(Var))) - 4)
        .Cells(i, 3).Value = Chaine
        .Hyperlinks.Add Anchor:=Cells(i, 3), Address:=mess & Chaine
        .Cells(i, 4) = Mid(Chaine, InStr(Chaine, "(") + 1, InStr(Chaine, ")_") - 2 - InStr(Chaine, "(") + 1)
        Chaine = Dir
    Loop
End With
Application.ScreenUpdating = True
End Sub

VBA m'indique une erreur 5 : "argument ou appel de procédure incorrect"
sur la ligne suivante :
Code: 
.Cells(i, 4) = Mid(Chaine, InStr(Chaine, "(") + 1, InStr(Chaine, ")_") - 2 - InStr(Chaine, "(") + 1)

J'ai tenté différents trucs mais je reste planté !

Merci par avance pour votre aide.
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro listing fichiers présents dans un dossier

Re
Si c'est bien le problème, essai ceci:
Code: 
[COLOR=blue]Sub[/COLOR] Num_Ulysse_3()
[COLOR=blue]Dim[/COLOR] mess$, mess2$, Chaine$, i#, Var
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
i = 4
mess = "[URL="file://\\Mariepierre\AAA_Tarifs"]\\Mariepierre\AAA_Tarifs[/URL] Clients en vigueur\"
mess2 = ".xls"
Chaine = Dir(mess & "*" & mess2)
[COLOR=blue]With[/COLOR] Sheets("Tarifs")
    [COLOR=blue]Do While[/COLOR] Chaine <> ""
        [COLOR=blue]If[/COLOR] InStr(Chaine, ")") <> 0 [COLOR=blue]And[/COLOR] InStr(Chaine, "(") <> 0 [COLOR=blue]Then[/COLOR]
            i = i + 1
            Var = Split(Chaine, "_")
            .Cells(i, 1) = Var([COLOR=blue]LBound[/COLOR](Var))
            .Cells(i, 2) = Mid(Var([COLOR=blue]UBound[/COLOR](Var)), 1, Len(Var([COLOR=blue]UBound[/COLOR](Var))) - 4)
            .Hyperlinks.Add Anchor:=.Cells(i, 3), Address:=mess & Chaine, TextToDisplay:=Chaine
            .Cells(i, 4) = Mid(Chaine, InStr(Chaine, "(") + 1, InStr(Chaine, ")") - InStr(Chaine, "(") - 1)
        [COLOR=blue]End If[/COLOR]
        Chaine = Dir
    [COLOR=blue]Loop[/COLOR]
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Cordialement
 
Vote positif 0 Vote négatif
D

dj dim

XLDnaute Occasionnel
Re : Macro listing fichiers présents dans un dossier

Salut Efgé,

J'ai effectué la modif et ca marche !!!

Etant novice je n'ai pas trop compris le pourquoi du comment de l'utilisation du "If" mais je me pencherais dessus ce weekend.

L'essentiel c'est que tout fonctionne et je t'en remercie vivement.

@ bientôt et merci encore
 
Vote positif 0 Vote négatif
D

dj dim

XLDnaute Occasionnel
Re : Macro listing fichiers présents dans un dossier

Bonjour à tous,

J'ai une nouvelle fois besoin de vos connaissances.

Le code communiqué par Efgé fonctionne à merveille et je le remercie une nouvelle fois pour ce formidable outil.

Le "soucis" aujourd'hui c'est que je souhaite que les fichiers ouverts à partir du lien ne soient :
- ni imprimables
- ni sauvegardables (via un copier coller) ou autre sytème

J'ai trouvé un code mais en l'inserant dans la partie Workbook, celui-ci ne s'applique qu'à mon fichier "répertoire".

Voici le code existant :

Code: 
Sub Num_Ulysse_3()
Dim mess$, mess2$, Chaine$, i#, Var
Application.ScreenUpdating = False
i = 5
mess = "\\Mariepierre\AAA_Tarifs Clients en vigueur\"
mess2 = ".xls"
Chaine = Dir(mess & "*" & mess2)
With Sheets("Tarifs")
    Do While Chaine <> ""
        If InStr(Chaine, ")") <> 0 And InStr(Chaine, "(") <> 0 Then
            i = i + 1
            Var = Split(Chaine, "_")
            .Cells(i, 1) = Var(LBound(Var))
            .Cells(i, 2) = Mid(Var(UBound(Var)), 1, Len(Var(UBound(Var))) - 4)
            .Hyperlinks.Add Anchor:=.Cells(i, 3), Address:=mess & Chaine, TextToDisplay:=Chaine
            .Cells(i, 4) = Mid(Chaine, InStr(Chaine, "(") + 1, InStr(Chaine, ")") - InStr(Chaine, "(") - 1)
        End If
        Chaine = Dir
    Loop
End With
Application.ScreenUpdating = True
End Sub


Merci par avance pour votre aide
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Macro listing fichiers présents dans un dossier

Bonjour dj dim, le fil, le forum,
Pour ta nouvelle demande je pense qu'il serait préférable d'ouvrir un nouveau fil. En tous cas, je n'ai aucune idée sur ce sujet...
Je te donne une autre version du code qui t'affichera la liste des classeurs dont le nom n'est pas "normé".
Code: 
[COLOR=blue]Sub[/COLOR] Num_Ulysse_4()
[COLOR=blue]Dim[/COLOR] Wb_Path$, Wb_Extension$, Wb_Name$, Msg$, i&, Tablo
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
i = 4: Msg = "Liste des fichiers non normés  : " & vbLf
Wb_Path = [URL="file://\\Mariepierre\AAA_Tarifs Clients en vigueur\"]\\Mariepierre\AAA_Tarifs Clients en vigueur\[/URL]
Wb_Name = Dir(Wb_Path & "*" & Wb_Extension)
[COLOR=blue]With[/COLOR] Sheets("Tarifs")
    [COLOR=blue]Do While[/COLOR] Wb_Name <> ""
        [COLOR=blue]If[/COLOR] Wb_Name [COLOR=blue]Like[/COLOR] "*_*(*)*_*" [COLOR=blue]Then[/COLOR]
            i = i + 1
            Tablo = Split(Wb_Name, "_")
            .Cells(i, 1) = Tablo([COLOR=blue]LBound[/COLOR](Tablo))
            .Cells(i, 2) = Mid(Tablo([COLOR=blue]UBound[/COLOR](Tablo)), 1, Len(Tablo([COLOR=blue]UBound[/COLOR](Tablo))) - 4)
            .Hyperlinks.Add Anchor:=.Cells(i, 3), Address:=Wb_Path & Wb_Name, TextToDisplay:=Wb_Name
            .Cells(i, 4) = Mid(Wb_Name, InStr(Wb_Name, "(") + 1, InStr(Wb_Name, ")") - InStr(Wb_Name, "(") - 1)
        [COLOR=blue]Else[/COLOR]
            Msg = Msg & vbLf & Wb_Name
        [COLOR=blue]End If[/COLOR]
        Wb_Name = Dir
    [COLOR=blue]Loop[/COLOR]
[COLOR=blue]End With[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]If[/COLOR] Len(Msg) > 32 [COLOR=blue]Then[/COLOR] MsgBox Msg
[COLOR=blue]End Sub[/COLOR]
Cordialement
 
Vote positif 0 Vote négatif

Discussions similaires

Nico2978
  • Résolu(e)
XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire
Réponses
5
Affichages
204
Nico2978
Nico2978
I
  • Question
Microsoft 365 Renommer des fichiers avec des caractères non reconnus
Réponses
10
Affichages
453
ivan27
I
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
1 K
saidoush
S
cathodique
  • Résolu(e)
XL 2010 Problème màj feuilles depuis fichiers CSV
2
Réponses
21
Affichages
619
cathodique
cathodique
F
  • Question
XL 2016 copier des fichiers dans des sous dossiers a partir de case a cocher sous excel
2
Réponses
17
Affichages
571
Felipe54
F
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
334
Dranreb
Dranreb
N
  • Question
XL 2016 Macro chargement liste arborescence, copier coller fichiers
Réponses
9
Affichages
391
Nermal64
N
N
  • Question
Microsoft 365 Exporter en csv vers un sharepoint
Réponses
0
Affichages
214
Negalo
N
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
192
aziz
A
B
  • Résolu(e)
XL 2013 Comment inversé l'ordre d'enregistrement des lignes dans un tableau
Réponses
6
Affichages
186
bedley
B

Membres actuellement en ligne

4 membres et 42 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 329
Messages
2 087 334
Membres
103 519
dernier inscrit
Thomas_grc11