Pagina Inicial‎ > ‎Excel‎ > ‎

Listar arquivos em pastas

Como listar todos os arquivos que estão em uma pasta e inserir hyperlinks para eles?

Simples!

Vamos a solução:

Private Sub FS(FoundFiles As Collection, DPath As String, Mask As String, IncludeSubdirectories As Boolean)

Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection

'adiciona barra se não encontrada
DPath = Trim(DPath)
If Right(DPath, 1) <> "\" Then DPath = DPath & "\"

' procura os arquivos de acordo com a mascara de entrada
DirFile = Dir(DPath & Mask)
Do While DirFile <> ""
FoundFiles.Add DirFile  'adiciona arquivo para a lista
DirFile = Dir ' next file
Loop

' procura em subdiretórios (vc pode desabilitar estes itens até o LOOP)
        If Not IncludeSubdirectories Then Exit Sub
        DirFile = Dir(DPath & "*", vbDirectory)
        Do While DirFile <> ""
            'Adiciona subdiretório
            If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(DPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add DPath & DirFile
            DirFile = Dir 'next file
        Loop

' processamento de subdiretórios
For Each CollectionItem In SubDirCollection
     Call FS(FoundFiles, CStr(CollectionItem), Mask, IncludeSubdirectories) ' Recursive procedure call
Next

End Sub


Sub FS_call()

Dim FWhPath As Variant
Dim LFWPath As New Collection    ' cria a coleção de nomes
I = 1

' preenche a coleção com os arquivos (no exemplo preenche com arquivos do excel 2003  que iniciem com "teste" e tbm nos subtiretórios)
Call FS(LFWPath, ActiveWorkbook.Path, "TESTE*.xls", True)

'  debug window e valores nas colunas a e b iniciando na linha 1 (I)
For Each FWPath In LFWPath    ' ciclo de processamento da lista
        Debug.Print FWPath & Chr(13)

        Cells(I, 2).Value = FWPath
        Cells(I, 1).Value = CollectionItem
        I = I + 1
       
Next FWPath


'  debug window e msgbox de nenhum arquivo encontrado
If LFWPath.Count = 0 Then
    Debug.Print "No file was found !"
    MsgBox "No file was found !"
End If


End Sub

Sub procv()
Range("a:b").ClearContents
Call FS_call
End Sub
Comments