Excel. Mejorar macro de búsqueda de archivos

Puedes poner una imagen de cómo están tus datos, pon 3 ejemplos un excle, un pdf y un dxf

Procura que se vean las filas y las columnas de excel.

Entiendo que tienes los nombres de los archivos en la columna M.

Qué valores tienes en la columna J, también que se vean en la imagen.

Entonces quieres los resultados así: N (pdf o excel) y O (dxf).

Adjunto imagen con Excel según lo solicitado. Ahora mismo me da las rutas de las carpetas donde están los archivos. Luego en el propio Excel le sumo el nombre del archivo para hacer hipervínculo en columnas P y Q, pero si se obtiene la ruta completa con el archivo y su extensión también me parece bien.

Realmente son los valores en la columna L (y no en J) los que indican las extensiones que existen de los archivos:

F1, F1S, F2, F2S- Extensión pdf

T- Extensión pdf y dxf

S- Extensión Excel (con nombre "Despiece " & referencia)

El resto no buscaría nada.

Muchas gracias.

En resumen, según tus información:

En mi caso en la columna N (pdf o excel) y O (dxf).

Prueba la siguiente macro:

- Cambia la ruta inicial sPath = "C:\trabajo\", por tu carpeta.

- Revisa los resultados, si algo no es correcto, me comentas y lo reviso.

Option Explicit
Dim rutas As New Collection
Sub Buscar_Archivos()
'DECLARACIÓN DE VARIABLES
  Dim sPath As String, sNombre As String, ext As String
  Dim arch As Variant, sd As Variant, a As Variant, b As Variant, vDatos As Variant
  Dim dic As Object, i As Long, j As Long
  '
'ENTRADA
  Range("N8:O" & Rows.Count).ClearContents
  a = Range("L8:M" & Range("M" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a), 1 To 2)
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  Set rutas = Nothing     'CARGA en rutas todas las carpetas
  sPath = "C:\trabajo\"   '"V:\PADRE"
  rutas.Add sPath
  Call AddSubDir(sPath)
  '
'PROCESO
  For Each sd In rutas
    arch = Dir(sd & "\*.*")
    Do While arch <> ""
      If InStrRev(arch, ".") > 0 Then
        sNombre = Left(arch, InStrRev(arch, ".") - 1)
        ext = Mid(arch, InStrRev(arch, ".") + 1)
        dic(sNombre) = dic(sNombre) & "|" & ext & "|" & sd
      End If
      arch = Dir()
    Loop
  Next
  '
  'Busca las referencias en Dic
  For i = 1 To UBound(a)
    Select Case UCase(Left(a(i, 1), 1))
      Case "F", "T", "S"            'F1, F1S, F2, F2S, T, S
        If dic.exists(a(i, 2)) Then
          vDatos = Split(dic(a(i, 2)), "|")
          For j = 1 To UBound(vDatos) Step 2
            Select Case LCase(vDatos(j))
              Case "dxf"            'O (dxf)
                b(i, 2) = vDatos(j + 1)
              Case Else             'N (pdf o excel)
                b(i, 1) = vDatos(j + 1)
            End Select
          Next
        End If
    End Select
  Next
'SALIDA
  Range("N8").Resize(UBound(b, 1), 2).Value = b
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    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 AddSubDir(sd)
  Next
End Sub

Realmente funciona muy bien. La búsqueda de archivos la hace rápida. En algún minuto que es normal con la cantidad de archivos y carpetas que tengo.

Solo hay una cosa que no me funciona. Sobre el ejemplo, en la fila 18 hay un referencia con CAT= "S". El archivos que debe buscar es el excel "Despiece FH-PG01(V01) (Rev.0)" ( "Despiece " & referencia).

Muchas gracias

¿Cuánto tiempo tardaba el proceso?

¿Y ahora cuánto tiempo tarda?

Se queda pensando un poco.He calculado unos 15 segundos. Lo que pasa es que alguna vez me ha tardado algún minuto pero será por cosas del ordenador. Antes me tardaba mucho más cuando la primera búsqueda no encontraba todos los archivos.Pero cuando sí lo hacía era inmediato.Pero esto se da muy pocas veces.

Pero para hacer todas las búsquedas de tu hoja, ¿cuánto tiempo tardaba tu macro?

Dependía de la cantidad de archivos no encontrados en la primera búsqueda y su ubicación.Pero podía tardar más de un minuto con cada uno.Si había mucho se hacía eterno.Tu macro funciona muy bien.Tengo una gran cantidad de carpetas y archivos y los encuentra realmente rápido.Solo me falta encontrar los excel para que sea perfecto para mí.