Dann könnte man das vielleicht so lösen (wie immer ausbaufähig):

Option Explicit
 
'siehe http://www.activevb.de/tipps/vb6tipps/tipp0605.html
Private Declare Function PathAddBackslash Lib "shlwapi.dll" _
  Alias "PathAddBackslashA" ( _
  ByVal pszPath As String) As Long
 
Sub Ausprobieren()
  
  Dim wks         As Excel.Worksheet
  Dim rngFileIDs  As Excel.Range
  Dim rngFileID   As Excel.Range
  Dim oFiles      As VBA.Collection
  Dim strPath     As String
  Dim strFile     As String
  Dim strFileN    As String
  Dim strFileID   As String
  Dim strFileIDN  As String
  Dim i&, k&, n&, nt&
  
  Set wks = ThisWorkbook.Worksheets(1)
  
  'Pfad zu dieser Arbeitsmappe
  strPath = AddBackslash(ThisWorkbook.Path)
  
  Debug.Print vbNewLine & "[" & Now & "]{'" & strPath & "'} >>>"
  
  'Liste mit IDs
  On Error Resume Next
  Set rngFileIDs = wks.Columns("A").SpecialCells(xlCellTypeConstants)
  On Error GoTo 0
  If Not rngFileIDs Is Nothing Then
    Set rngFileIDs = rngFileIDs.Cells
  Else
    Debug.Print " # keine ID-Liste vorhanden"
    Debug.Print "<<<"
    Call MsgBox("Keine ID-Liste vorhanden.", vbInformation)
    Exit Sub
  End If
  
  'suche nach Dateien im Pfad der Arbeitsmappe (mit Filter nach Dateierweiterung)
  Call GetFiles(strPath, oFiles, "*.bmp;*.jpg")
  
  nt = oFiles.Count 'Anzahl der gefundenen Dateien
  
  'alle IDs in der Liste durchgehen
  For Each rngFileID In rngFileIDs
    
    If oFiles.Count = 0 Then Exit For
    
    strFileID = Trim$(rngFileID.Text)               'die aktuell betrachtete ID
    strFileIDN = Trim$(rngFileID.Offset(, 1).Text)  'die neue ID
    
    If strFileIDN = "" Then
    'Problem: die neue FileID ist in der Liste nicht angegeben
      Debug.Print " ? " & strFile & " (ID: " & strFileID & ") | neue FileID in Liste nicht angegeben)"
      
    Else
      k = 0 'Datei-Index (falls notwendig)
      
      'die aktuelle ID mit allen Dateien vergleichen
      '(und ggf. die Datei umbenennen)
      For i = oFiles.Count To 1 Step -1
        
        strFile = Trim$(oFiles(i)) 'Dateiname
        
        If FileCheck(strFile, strFileID) Then
        'die aktuelle betrachtete ID kommt im Dateinamen vor
          
          If k > 0 Then
            strFileN = FilenameNew(strFile, strFileIDN & "_" & k)
          Else
            strFileN = FilenameNew(strFile, strFileIDN)
          End If
          
          'umbenennen
          On Error Resume Next
            'datei umbenennen
            Name strPath & strFile As strPath & strFileN
            If Err.Number = 0 Then
            'OK
              n = n + 1
              Debug.Print " # DATEI '" & strFile & "' >> '" & strFileN & "'"
            Else
            'Fehler
              Debug.Print " ! DATEI '" & strFile & "' (ID '" & strFileID & "' | konnte NICHT umbenannt werden (Fehler " & Err.Number & "; " & Err.Description & ")"
            End If
          On Error GoTo 0
          
          k = k + 1
          
          oFiles.Remove i
        End If
        
      Next
        
        If k = 0 Then
          Debug.Print " # ID '" & strFileID & "' | es wurde keine passende Datei gefunden"
        End If
      
    End If
    
  Next
  
  For i = 1 To oFiles.Count
    Debug.Print " # DATEI '" & oFiles(i) & "' | blieb unangetastet"
  Next
  
  Debug.Print "<<<"
  
  Call MsgBox("Datei-Anzahl: " & nt & vbNewLine & _
              "davon umbenannt: " & n, _
              vbInformation)
  
End Sub
 
Private Function FileCheck(ByVal Filename As String, ByVal FileID As String) As Boolean
  Dim n$
  Call FileInfo(Filename, n, vbNullString)
  FileCheck = (StrComp(Left$(n, Len(FileID)), FileID, vbTextCompare) = 0)
End Function

Private Function FilenameNew(ByVal OldFilename As String, ByVal NewFilename As String, Optional KeepExtension As Boolean = True) As String
  
  OldFilename = Trim$(OldFilename)
  NewFilename = Trim$(NewFilename)
  
  Dim strN$, strE1$, strE2$
  
  Call FileInfo(OldFilename, vbNullString, strE1)
  Call FileInfo(NewFilename, strN, strE2)
  
  If KeepExtension Then
    FilenameNew = strN & "." & strE1
  Else
    FilenameNew = strN & "." & strE2
  End If
  
End Function

Private Sub FileInfo(ByVal Filename As String, ByRef Name As String, ByRef Extension As String)
  
  Filename = Trim$(Filename)
  
  Dim i As Long
  i = InStrRev(Filename, ".")
  If CBool(i) Then
    Name = Left$(Filename, i - 1)
    Extension = Right$(Filename, Len(Filename) - i)
  Else
    Name = Filename
    Extension = ""
  End If
  
End Sub

Private Sub GetFiles(ByVal Path As String, File As VBA.Collection, Filter As String, Optional Separator As String = ";")
  
  Dim clc As New VBA.Collection
  Dim vnt As Variant
  Dim strFile$, strExt$
  Dim n&, i&
  
  Path = AddBackslash(Path)
  
  vnt = Split(Filter, Separator)
  
  strFile = Dir(Path & "*.*")
  While strFile <> ""
    For i = LBound(vnt) To UBound(vnt)
      If strFile Like vnt(i) Then
        clc.Add strFile
        Exit For
      End If
    Next
    strFile = Dir()
  Wend
  
  Set File = clc
   
  Erase vnt
   
End Sub
 
'siehe http://www.activevb.de/tipps/vb6tipps/tipp0605.html
Private Function AddBackslash(ByVal Path As String) As String
  ' Sicherstellen, dass sich am Ende des Pfades ein \
  ' befindet, also nicht "C:\windows", sondern "C:\windows\"
  Dim sBuf As String
  sBuf = Path + String(100, 0)
  Call PathAddBackslash(sBuf)
  AddBackslash = RemNulls(sBuf)
End Function
 
'siehe http://www.activevb.de/tipps/vb6tipps/tipp0605.html
Private Function RemNulls(ByVal sStr As String) As String
  ' Entfernt die Nullzeichen am Ende eines Strings
  Dim lPos As Long
  lPos = InStr(1, sStr, vbNullChar)
  If lPos > 0 Then
      RemNulls = Left(sStr, lPos - 1)
  Else
      RemNulls = sStr
  End If
End Function