Pessoal,

Uso uma macro para retornar o resultado de pesquisa de arquivos, mas preciso melhorar a mesma para retornar busca dos arquivos de forma automática, isto é, se forem inseridos novos arquivos, a mesma já autualizava sua base e retornava a pesquisa com esses novos arquivos, sem a necessidade de inserção manual na mesma.
Abaixo segue o código:

Dim lst As New Collection
Dim sServerEnviroment As New Collection

Function getFileVersion(ByVal serverName As String, ByVal strPath As String, ByVal strFilename As String, ByVal strEnv As String) As String
Dim fullPat As String

'Call FileSearch

If UCase(serverName) = UCase("nameserver") Then
fullpath = "\" & serverName & strPath & strFilename
ElseIf serverName = "nameserver" And strEnv = "NEW_UAT" Then
fullpath = "\" & serverName & "c$" & strPath & strFilename
Else
fullpath = "\" & serverName & "c$" & strPath & strFilename
End If
'MsgBox (fullpath)
If FileExists(fullpath) Then
Dim oFS As Object

'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")

If oFS.getFileVersion(fullpath) = "" Then
getFileVersion = "No Version"
Else
getFileVersion = oFS.getFileVersion(fullpath)
End If
Set oFS = Nothing
Else
getFileVersion = ""
End If
End Function

Function getFileDate(ByVal serverName As String, ByVal strPath As String, ByVal strFilename As String, ByVal strEnv As String) As String
Dim fullPat As String

'Call FileSearch

If UCase(serverName) = UCase("nameserver") Then
fullpath = "\" & serverName & strPath & strFilename
ElseIf serverName = "nameserver" And strEnv = "NEW_UAT" Then
fullpath = "\" & serverName & "c$" & strPath & strFilename
Else
fullpath = "\" & serverName & "c$" & strPath & strFilename
End If
'MsgBox (fullpath)
If FileExists(fullpath) Then
Dim oFS As Object

'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")

If oFS.getFileVersion(fullpath) = "" Then
getFileDate = "No Version"
Else
getFileDate = FileDateTime(fullpath)
End If
Set oFS = Nothing
Else
getFileDate = ""
End If

End Function

Function FileExists(ByVal fname As String) As Boolean
' Returns TRUE if the file exists
Dim x As String
x = Dir(fname)

If x <> "" Then
FileExists = True
Else
FileExists = False
End If
End Function
Sub fileVersionColor(ByVal strLastVersion As String)
If strLastVersion <> ActiveCell.Value Then
ActiveCell.Font.Color = RGB(255, 0, 0)
End If
End Sub

Function getFileVersionTest(ByVal serverName As String, ByVal strPath As String, ByVal strFilename As String, ByVal strEnv As String, ByVal strLastVersion As String)

As String
Dim fullPat As String
If serverName = "nameserver" Then
fullpath = "\" & serverName & "sistemasop1" & strEnv & strPath & strFilename
ElseIf serverName = "nameserver" And strEnv = "NEW_UAT" Then
fullpath = "\" & serverName & "c$" & strPath & strFilename
Else
fullpath = "\" & serverName & "c$" & strPath & strFilename
End If
'MsgBox (fullpath)
If FileExists(fullpath) Then
Dim oFS As Object
'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")
If oFS.getFileVersionTest(fullpath) = "" Then
getFileVersionTest = "No Version"
Else
getFileVersionTest = oFS.getFileVersion(fullpath)
End If
Set oFS = Nothing
Else
getFileVersionTest = ""
End If
fileVersionColor (strLastVersion)
End Function

Sub clean()
ActiveSheet.Range("b3", ActiveCell.SpecialCells(xlLastCell)).Delete
End Sub

'fileName = "mapping"
'Path = "\nameserversistema123sistemainterfacereconinterfacebin"
'Call FileSearch2007(ColFiles, Path, fileName, True)

Sub FileSearch()
Dim sStartPath As String
Dim sFile As String
Dim result As String
Dim t As Integer
Dim tmp As String
Dim sEnvironment As String
Dim sEnvPath As String
Dim contQtdServer As Integer

'Ambiente01
'nameserver01
'nameserver02
'nameserver03
'nameserver04
'nameserver05
'nameserver06
'nameserver07

sEnvironment = ThisWorkbook.Sheets(2).Cells(1, 2)

If sServerEnviroment.Count > 0 Then
Do
sServerEnviroment.Remove (sServerEnviroment.Count)
Loop Until sServerEnviroment.Count = 0
End If

' srvEnvironment
Select Case UCase(sEnvironment)
Case UCase("Ambiente01")
sServerEnviroment.Add "nameserver01"
sServerEnviroment.Add "nameserver02"
sServerEnviroment.Add "nameserver03"
sServerEnviroment.Add "nameserver04"
sServerEnviroment.Add "nameserver05"
sServerEnviroment.Add "nameserver06"
sServerEnviroment.Add "nameserver07"
sServerEnviroment.Add "nameserver08"
sServerEnviroment.Add "nameserver09"
sEnvPath = "sistemasop1Ambiente01value"
sServerEnviroment.Add "nameserver"
' sServerEnviroment.Add "c:xml"
Case UCase("Ambiente02")
sServerEnviroment.Add "nameserver01"
sServerEnviroment.Add "nameserver02"
sServerEnviroment.Add "nameserver03"
sServerEnviroment.Add "nameserver04"
sServerEnviroment.Add "nameserver05"
sServerEnviroment.Add "nameserver06"
sServerEnviroment.Add "nameserver07"
sServerEnviroment.Add "nameserver08"
sServerEnviroment.Add "nameserver09"
sEnvPath = "sistemasop1Ambiente02value"
sServerEnviroment.Add "nameserver"
' sServerEnviroment.Add "c:xml"
End Select

'fullpath = DigIn("C:xml", "fred")
'sStartPath = ThisWorkbook.Sheets(2).Cells(1, 2) 'Where?
'sWhat = ThisWorkbook.Sheets(2).Cells(1, 2) 'What?
contQtdServer = sServerEnviroment.Count
sFile = UCase(ThisWorkbook.Sheets(2).Cells(2, 2))

If contQtdServer > 0 Then
Do
If UCase(sServerEnviroment(contQtdServer)) = UCase("nameserver") Then
sStartPath = "\" & sServerEnviroment(contQtdServer) & sEnvPath & strEnv & strPath & strFilename
'ElseIf UCase(sServerEnviroment(contQtdServer)) = UCase("nameserver") And strEnv = "NEW_UAT" Then
' sStartPath = "\" & sServerEnviroment(contQtdServer) & "c$" & strPath & sFile
ElseIf UCase(sServerEnviroment(contQtdServer)) = UCase("nameserver") Or _
UCase(sServerEnviroment(contQtdServer)) = UCase("nameserver") Then
sStartPath = "\" & sServerEnviroment(contQtdServer) & "c$ow1"
ElseIf UCase(sServerEnviroment(contQtdServer)) = UCase("c:xml") Then
sStartPath = sServerEnviroment(contQtdServer) & ""
Else
sStartPath = "\" & sServerEnviroment(contQtdServer) & "c$sistemas123sistema"
'sStartPath = "\" & sServerEnviroment(contQtdServer) & "c$sistemas123InstallationReadyToUse1236"
'sStartPath = "\" & sServerEnviroment(contQtdServer) & "c$sistemas123Installationgold1236"
End If

If lst.Count > 0 Then
Do
lst.Remove lst.Count 'clears list if data already exists
Loop Until lst.Count = 0
End If
ThisWorkbook.Sheets(2).Cells(3, contQtdServer + 1).Value = sServerEnviroment(contQtdServer)
'ActiveCell.Value = ""
'ActiveCell.ClearContents
'ThisWorkbook.Sheets(1).Columns(1).ClearContents

result = DigIn(sStartPath, sFile) 'First step

For t = lst.Count To 1 Step -1
tmp = lst(t)
ThisWorkbook.Sheets(2).Cells(3 + t, contQtdServer + 1).Value = lst(t)
'ActiveCell.Value = lst(t)
'ThisWorkbook.Sheets(2).Cells(2, 4) = lst(t) 'puts data in 1st sheet, 1st column
lst.Remove t
Next t

'Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

contQtdServer = contQtdServer - 1

Loop Until contQtdServer = 0
End If
End Sub

Function DigIn(sPath As String, sWhat As String) As String
Dim fs
Dim dDirs
Dim dDir
Dim fFile
Dim c As Variant
Dim tmp As String

Set fs = CreateObject("Scripting.FileSystemObject")
Set dDirs = fs.GetFolder(sPath & "")

For Each dDir In dDirs.SubFolders
tmp = DigIn(dDir.Path, sWhat)
Next
'tmp = Dir(dDirs.Path & "*" & sWhat & "*.*")
tmp = Dir(dDirs.Path & "*" & sWhat)
If tmp <> "" Then
Do
lst.Add dDirs.Path & "" & tmp
tmp = Dir
Loop Until tmp = ""
Exit Function
End If
End Function

Agradeço desde já pela ajuda!
Abraços,
J Rafael.