Macro listing fichiers présents dans un dossier

dj dim · 9 Novembre 2010

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.

Efgé · 9 Novembre 2010

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

dj dim · 9 Novembre 2010

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é ! 🙂

dj dim · 15 Novembre 2010

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.

Efgé · 15 Novembre 2010

Re : Macro listing fichiers présents dans un dossier

Bonjour dj dim, le fil, le forum,
Je pense que le nom d'un des classeur n'est pas "normalisé" . Il manque certainement les parenthèses.
A vérifier
Cordialement

Efgé · 15 Novembre 2010

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

dj dim · 15 Novembre 2010

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

dj dim · 23 Novembre 2010

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

Efgé · 23 Novembre 2010

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

Macro listing fichiers présents dans un dossier

dj dim

XLDnaute Occasionnel

Efgé

XLDnaute Barbatruc

dj dim

XLDnaute Occasionnel

dj dim

XLDnaute Occasionnel

Efgé

XLDnaute Barbatruc

Efgé

XLDnaute Barbatruc

dj dim

XLDnaute Occasionnel

dj dim

XLDnaute Occasionnel

Efgé

XLDnaute Barbatruc

Discussions similaires

Macro listing fichiers présents dans un dossier

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency