Private Const strPath As String = "D:\2\"

Public Sub FindFiles()
    
    Dim strFile As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim blnFlag As Boolean
    
    Set ws = ThisWorkbook.Worksheets("Лист1")
    Set rng = ws.Range("A1:A3")
    
    For Each rng In rng
        
        blnFlag = False
        strFile = Dir(strPath)
        
        Do Until strFile = ""
            If rng.Value = fnGetFileName(strFile) Then
                blnFlag = True
                Exit Do
            End If
            strFile = Dir
        Loop
        
        If blnFlag Then
            rng.Offset( 0 ,  1 ) = "Есть"
        Else
            rng.Offset( 0 ,  1 ) = "Нет"
        End If
        
    Next rng
End Sub

Public Function fnGetFileName( _
  strFileName As String) As String
  
    Dim intI As Integer
    
    intI = InStrRev(strFileName, ".")
    
    If intI >  0  Then
        fnGetFileName = Mid(strFileName,  1 , intI -  1 )
    End If
End Function

   A      B
1 123	Есть
2 1234	Есть
3 123456	Нет