com algumas pesquisas, consegui montar uma parte do que preciso, porem quando renomeio o arquivo ou copio o VBA para uma outra planilha, ela da erro, alguém sabe onde corrigo?

'Esta macro lista os arquivos em um determinado Diretório

Sub Testar_Lista_Arquivos_nas_pastas()
Dim RootFolder$

 

  'Diretório à scanear
  RootFolder = "h:/exp/controle de fretes/comprovantes de entrega/"

  If RootFolder = "" Then Exit Sub
  ' create a new sheets for the file list
     Sheets.Add
  ' add headers

  With Range("A1")
    .Formula = "Comprovantes Encontrados em: " & RootFolder
    .Font.Bold = True
    .Font.Size = 12
  End With

 Range("A3").Formula = "Caminho: "
 Range("B3").Formula = "Nome : "
 Range("C3").Formula = "Data Criação : "
 Range("D3").Formula = "Data último Accesso : "
 Range("E3").Formula = "Data última Modificação : "

  
 With Range("A3:E3")
   .Font.Bold = True
   .HorizontalAlignment = xlCenter
   .VerticalAlignment = xlCenter
   .WrapText = True

 End With

  ' list all files included subfolders

ListFilesInFolder RootFolder, True
Columns("A:H").AutoFit

End Sub

'
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:FolderName", True

Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long

 
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)

r = Range("A65536").End(xlUp).Row + 1

For Each FileItem In SourceFolder.Files
   'display file properties

   Cells(r, 1).Formula = FileItem
   Cells(r, 2).Formula = FileItem.Name
   Cells(r, 3).Formula = FileItem.DateCreated
   Cells(r, 3).NumberFormatLocal = "dd / mm / aaaa"
   Cells(r, 4).Formula = FileItem.DateLastAccessed
   Cells(r, 5).Formula = FileItem.DateLastModified
   Cells(r, 5).NumberFormatLocal = "dd / mm / aaaa"
   ' next row number

    r = r + 1
Next FileItem

If IncludeSubfolders Then
   For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
   Next SubFolder
End If

Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing

ActiveWorkbook.Saved = True

End Sub

 

Private Function Localiza_Dir()
Dim objShell, objFolder, chemin, SecuriteSlash

                                            
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = _
        objShell.BrowseForFolder(&H0&, "Saberexcel - Procurar por um Diretório", &H1&)
    On Error Resume Next

    chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""

    If objFolder.Title = "Bureau" Then
        chemin = "C:WindowsBureau"
    End If

    If objFolder.Title = "" Then
        chemin = ""
    End If

    
    SecuriteSlash = InStr(objFolder.Title, ":")
    If SecuriteSlash > 0 Then
       chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
    End If

    Localiza_Dir = chemin

End Function

Amigo, segue um código mais simples. Veja se atende.

Sub hiperlink_arquivos()
Dim Pasta1, Pasta2 As String
Dim Arq, Arq1 As String
Dim i As Long
i = 2
Pasta1 = "c:caminho" 'Inserir o caminho da primeira pasta no diretório
Pasta2 = "c:caminho" 'Inserir o caminho da segunda pasta no diretório
For i = 2 To Range("A100000").End(xlUp).Row
lextensao = ".*"
tpArq = Range("A" & i).Value & ".*"
Arq = Dir(Pasta1 & tpArq, vbDirectory)
Arq1 = Dir(Pasta2 & tpArq, vbDirectory)
If Arq <> "" Then
Range("B" & i).Hyperlinks.Add Anchor:=Range("B" & i), Address:= _
Pasta1 & Arq, TextToDisplay:="Encontrado"
Else
Range("B" & i) = "Não Encontrado"
End If
If Arq1 <> "" Then
Range("C" & i).Hyperlinks.Add Anchor:=Range("C" & i), Address:= _
Pasta2 & Arq1, TextToDisplay:="Encontrado"
Else
Range("C" & i) = "Não Encontrado"
End If
Next i
End Sub