Listar todos os arquivos que estão em uma pasta e inserir hyperlinks

 

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