Modificar macro que busca archivos y cambia de color el texto dependiendo si esta o no, para que la búsqueda abarque subcarpetas

Ya tengo dos macros una ya realiza la búsqueda en subcarpetas y la otra macro que solo buscaba en una carpeta y hace el cambio de color dependiendo si encontró o no el archivo intente modificarla para que en la macro que realiza la revisión de si están o no los archivos también accediera la búsqueda en las subcarpetas pero no me queda espero me pueda ayudar a estructurarla a continuación le dejo las macros por separado gracias :3

Búsqueda en carpeta y subcarpetas

Dim rutas As New Collection
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Por.Dante Amor
    If Target.Column <> 2 Then Exit Sub 'sólo se ejecutará en col B'
    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 "C:\Users\cari\Documents\libros\" '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\Reader 9.0\Reader\AcroRd32.exe " & arch
    Else
        If MsgBox("no fue localizado desea buscarlo manualmente", vbYesNo, "ATENCION") = vbNo Then Exit Sub
        On Error GoTo salida
        ChDir "C:\Users\cari\Documents\libros\"
        archivo = Application.GetOpenFilename
        If archivo = False Then Exit Sub
        Shell "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe " & archivo
        Exit Sub
    End If
salida:     MsgBox "Listo"
End Sub
'
Function encuentraarch(nuevo)
'Por.Dante Amor
    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)
'Por.Dante Amor
    '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

lo que necesito es que la macro revisar archivos también realice la busqueda en las subcarpetas copie las no encontradas en la hoja 5 a partir de la celda A1 y que se limpie la hoja5 cada que se ejecute la macro revisar archivo,  que se complemente o integre la macro de arriba con la de abajo a la hora de hacer la revisión en los comentarios le dejo la macro revisiónArchivo 

De antemano gracias :3 espero tenga lindo día y muy buen Fin de semana