Bonjour à tour,
Je dispose d'un code que je n'arrive pas à copier dans un nouveau classeur (celui-ci bug) mais je n'arrive pas à comprendre pourquoi, pouvez-vous m'aider svp? Ce code me permet de lister des fichiers *.xsl* contenant le mot Devis à partir d'une racine de dossier source qui se trouve dans la cellule B2 de la feuil
Public ListeDoss() As String
Sub ChercheDoss(Chemin1 As String)
Dim Ligne As Long, Nom As String
Ligne = Range("A65536").End(xlUp).Row + 1
On Error GoTo Err1
Nom = Dir(Chemin1 & "\*" & Range("Texte").Value & "*" & Range("Ext").Value)
If Nom <> "" Then
Cells(Ligne, 1).Value = Chemin1 & "\" & Nom
Cells(Ligne, 2).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 3), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
Do
Ligne = Range("A65536").End(xlUp).Row + 1
Nom = Dir
If Nom <> "" Then
Cells(Ligne, 1).Value = Nom
Cells(Ligne, 2).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 3), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
End If
Loop Until Nom = ""
End If
Err1:
End Sub
Sub ChercheTout()
Dim Chemin As String, i As Long
Range("A7:C65536").Clear
Chemin = Range("Doss").Value
LanceListe Chemin
For i = 1 To UBound(ListeDoss)
ChercheDoss ListeDoss(i)
Next i
End Sub
Sub ListeArborescence(Dossier As String)
Dim fs, sousdoss
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each sousdoss In fs.getfolder(Dossier).subfolders
ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
ListeDoss(UBound(ListeDoss)) = sousdoss.Path
ListeArborescence sousdoss.Path
Next sousdoss
On Error GoTo 0
Set fs = Nothing
End Sub
Sub LanceListe(Dossier As String)
ReDim ListeDoss(1 To 1)
ListeDoss(1) = Dossier
ListeArborescence Dossier
End Sub