Macro que abra archivo .PDF alojado en carpeta externa que coincida el nombre exacto y anexar la terminación .PDF

Disculpe ya tengo la macro que me busca y abre el archivo a partir de la coincidencia con parte del nombre del archivo y anexando la terminación .PDF en caso de no tenerlo realizando la búsqueda a partir de una carpeta y dentro de sus subcarpetas quiero saber como modificarla para que me realice la búsqueda en la cual coincida el nombre exacto

En este caso los nombres de los archivos vienen así

Por numeración

nombre archivo columna A                               nombre archivo carpeta externa

0001                                                                                 1.pdf

0002                                                                                 2.pdf

0003                                                                                 3.pdf

0004                                                                                 4.pdf

los 3 ceros a la izquierda solo son parte del formato de la celda 

espero me puedan ayudar de antemano gracias :3

Dim rutas As New Collection

'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub 'sólo se ejecutará en col A'
If Target.Row < 9 Then Exit Sub 'sólo se ejecuta a partir de la fila 9'
If Target.Value = " " Or Target.Value = "" Then Exit Sub 'no se ejecutara en celdas vacias
ChDir "D:\DOCUMENTOS\" 'ruta de carpeta donde estan los documentos
'ChDir ThisWorkbook.Path & "\"
'ChDir "C:\trabajo\"
Set rutas = Nothing
nombre = Target.Value
If UCase(Right(nombre, 4)) = ".PDF" Then
nuevo = Left(nombre, Len(nombre) - 4)
Else
nuevo = nombre
End If
arch = encuentraarch(nuevo)
If arch <> "" Then
If MsgBox("el archivo existe. Desea abrirlo??", vbYesNo, "ATENCION") = vbNo Then Exit Sub
'ActiveWorkbook.FollowHyperlink arch
Shell "C:\Program Files (x86)\Adobe\Acrobat 9.0\Acrobat\Acrobat.exe " & arch
Else
If MsgBox("no fue localizado desea buscarlo manualmente", vbYesNo, "ATENCION") = vbNo Then Exit Sub
On Error GoTo salida
ChDir "D:\DOCUMENTOS " 'modificar ruta de carpeta de inicio
archivo = Application.GetOpenFilename
If archivo = False Then Exit Sub
Shell "C:\Program Files (x86)\Adobe\Acrobat 9.0\Acrobat\Acrobat.exe " & archivo
Exit Sub
End If
salida: MsgBox "Listo"
End Sub

'
Function encuentraarch(nuevo)
On Error Resume Next
pPath = CurDir()
rutas.Add pPath
pPath = pPath & "\"
Call agregadir(pPath)
For Each sd In rutas
dato = sd & "\*" & nuevo & "*.pdf"
arch = Dir(sd & "\*" & nuevo & "*.pdf")
Do While arch <> ""
encuentraarch = sd & "\" & arch
Exit Function
Loop
Next
Set rutas = Nothing
End Function
'
Sub agregadir(lpath)
'Agrega directorios
Dim SubDir As New Collection
If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
DirFile = Dir(lpath & "*", vbDirectory)
Do While DirFile <> ""
'Agrega subdirectorios a collection
If DirFile <> "." And DirFile <> ".." Then _
If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
SubDir.Add lpath & DirFile
DirFile = Dir
Loop
'
For Each sd In SubDir
rutas.Add sd
Call agregadir(sd)
Next
End Sub
'
Sub RevisarArchivos()
Application.ScreenUpdating = False
'Set h5 = Sheets("Hoja5")
'h5.Cells.Clear
'j = 9
For i = 9 To Range("A" & Rows.Count).End(xlUp).Row
ChDir "D:\DOCUMENTOS\"
'ChDir ThisWorkbook.Path & "\"
'ChDir "C:\trabajo\"
nombre = Cells(i, "B")
If UCase(Right(nombre, 4)) = ".PDF" Then
nuevo = Left(nombre, Len(nombre) - 4)
Else
nuevo = nombre
End If
'
arch = encuentraarch(nuevo)
If arch <> "" Then
Cells(i, "A").Font.ColorIndex = 0
Else
Cells(i, "A").Font.ColorIndex = 18
'vbBlack
'Rows(i).Copy
' h5.Cells(j, "A").PasteSpecial xlValues
'j = j + 1
End If
Next
'Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub