En lugar de recorrer una lista de archivos, puede verificar directamente con Dir y comodines si existe un archivo.

p.ej. puede usar Dir("C:\Temp\myNumber*.pdf") para encontrar un archivo llamado myNumberAndUnusefulText.pdf . Entonces, si usa fileName = Dir("Some\Directory\Here\" & CSheet & "*.pdf") , devolverá el nombre de archivo de un archivo que comienza con el número en CSheet .

Leer más todos los valores en una matriz primero y luego procesar la matriz hace que su código sea mucho más rápido. Las acciones de lectura y escritura en las celdas consumen mucha sobrecarga y, por lo tanto, son lentas. Al leer los valores en una matriz, la reduce a solo una lectura de celda y una acción de escritura de celda.

 Option Explicit Public Sub LoopFilesImproved() Dim CCNums As Range Set CCNums = ThisWorkbook.Worksheets("Sheet1").Range("BC4:BC68512") ' always specify in which sheet a range is! ' define output range Dim Output As Range Set Output = CCNums.Offset(ColumnOffset:=1) ' read output range into array for faster processing Dim OutputValues() As Variant OutputValues = Output.Value2 ' read all values into an array for faster processing Dim CCNumsValues() As Variant CCNumsValues = CCNums.Value2 ' loop through numbers and check if a file exists Dim iCCNum As Long For iCCNum = LBound(CCNumsValues, 1) To UBound(CCNumsValues, 1) Dim CSheet As String CSheet = Left$(CCNumsValues(iCCNum, 1), 6) Dim fileName As String fileName = Dir("Some\Directory\Here\" & CSheet & "*.pdf") If fileName <> vbNullString Then OutputValues(iCCNum, 1) = "Available" Else OutputValues(iCCNum, 1) = "Not Found" End If Next iCCNum ' write array values back to cell Output.Value2 = OutputValues End Sub

Puede intentar recopilar primero todos los nombres de archivo en un diccionario; a partir de ese momento, la comprobación será rápida...

 Sub LoopFiles() Dim dictFiles As Object, arrCC, arrAv, rngCC As Range, r As Long Set dictFiles = FileIds("Some\Directory\Here\*.pdf") 'collect all the file Id's Set rngCC = ActiveSheet.Range("BC4:BC68512") arrCC = rngCC.Value ReDim arrAv(1 To UBound(arrCC, 1), 1 To 1) 'size the "available?" array For r = 1 To UBound(arrCC, 1) 'loop data from BC id = Left(arrCC(r, 1), 6) 'extract the id arrAv(r, 1) = IIf(dict.exists(id), "Available", "Not found") Next r rngCC.Offset(0, 1).Value = arrAv 'populate availability in BD End Sub 'scan all files matching the `folderPath` pattern, and return a Dictionary object ' with keys equal to the first 6 characters of the file names Function FileIds(folderPath As String) Dim dict As Object, f, id Set dict = CreateObject("scripting.dictionary") f = Dir(folderPath) Do While Len(f) > 0 If Len(f) >= 10 Then dict(Left(f, 6)) = True 'need at least 10 chars with the extension f = Dir() Loop Set FileIds = dict End Function

En una prueba rápida en una unidad local con 30k archivos, llamar a FileIds tomó alrededor de 0,08 segundos. Llamar a Dir() 65k veces en la misma carpeta tomó 12-13 segundos.

Actualizar la disponibilidad de archivos mediante una lista

 Option Explicit Sub UpdateFilesAvailability() Const FolderPath As String = "C:\Test" Const RightFilePart As String = "*.pdf" Const idLen As Long = 6 Const sRangeAddress As String = "BC4:BC68512" Const dCol As String = "BD" Const dYes As String = "Available" Const dNo As String = "Not found" Const Msg As String = "Files availability updated." ' Validate the folder path. Dim fPath As String: fPath = FolderPath If Right(fPath, 1) <> "\" Then fPath = fPath & "\" If Len(Dir(fPath, vbDirectory)) = 0 Then MsgBox "The folder '" & fPath & "' doesn't exist.", vbCritical Exit Sub End If ' Reference the worksheet ('ws'). Dim ws As Worksheet: Set ws = ActiveSheet ' improve! ' Reference the source range ('srg'). Dim srg As Range: Set srg = ws.Range(sRangeAddress) ' Write the values from the source range ' to a 2D one-based one-column array ('Data'). Dim Data As Variant: Data = srg.Value Dim cString As String ' Current String Dim fName As String ' Current File Name Dim r As Long ' Current Array Row Dim FileFound As Boolean ' Loop through the rows of the destination array and replace its values ' with the results. For r = 1 To UBound(Data, 1) cString = CStr(Data(r, 1)) If Len(cString) >= idLen Then fName = Dir(fPath & Left(cString, idLen) & RightFilePart) If Len(fName) > 0 Then FileFound = True End If If FileFound Then Data(r, 1) = dYes FileFound = False Else Data(r, 1) = dNo End If Next r ' Reference the destination range. Dim drg As Range: Set drg = srg.EntireRow.Columns(dCol) ' Write the values from the array to the destination range. drg.Value = Data 'drg.EntireColumn.AutoFit 'ws.Parent.Save ' save the workbook MsgBox Msg, vbInformation End Sub