Datensicherung vorher nicht vergessen.

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 rngResult   As Excel.Range
  Dim f()         As String
  Dim strPath     As String
  Dim strFileN    As String
  Dim strFileID   As String
  Dim n           As Long
  Dim i           As Long
  
  Set wks = ThisWorkbook.Worksheets(1)
  
  strPath = AddBackslash(ThisWorkbook.Path)
  
  n = GetJPGs(strPath, f)
  
  Debug.Print vbNewLine & Now & " >>>"
  For i = 1 To n
    
    strFileID = GetID(f(i))
    
    Set rngResult = wks.Columns("A").Find(strFileID)
    If Not rngResult Is Nothing Then
      
      strFileN = Trim$(wks.Columns("B").Rows(rngResult.Row).Text)
      
      'neuer Dateiname darf noch nicht existieren
      If Not Dir(strPath & strFileN) <> "" Then
        
        On Error Resume Next
          'datei umbenennen
          Name strPath & f(i) As strPath & strFileN
          If Err.Number = 0 Then
          'OK
            Debug.Print " # " & f(i) & " >> " & strFileN
          Else
          'Fehler
            Debug.Print " ! " & f(i) & " | ID " & strFileID & " konnte NICHT umbenannt werden (Fehler " & Err.Number & "; " & Err.Description & ")"
          End If
        On Error GoTo 0
        
      Else
        'Problembehandlung
        Debug.Print " ? " & f(i) & " >> " & strFileN & " | wurde nicht ausgeführt (Zieldatei existiert bereits)"
      End If
      
    Else
      'Problembehandlung
      Debug.Print " ? " & f(i) & " | ID " & strFileID & " konnte NICHT in Liste gefunden werden"
    End If
    
  Next
  Debug.Print "<<<"
  
End Sub

Private Function GetID(File As String) As String
  Dim i As Long
  For i = 1 To Len(File)
    If IsNumeric(Mid$(File, i, 1)) Then
      GetID = GetID & Mid$(File, i, 1)
    Else
      Exit For
    End If
  Next
End Function

Private Function GetJPGs(Path As String, File() As String) As Long
  
  Dim f() As String
  Dim strFile$
  Dim n&
  
  strFile = Dir(Path & "*.jpg")
  While strFile <> ""
    n = n + 1
    ReDim Preserve f(1 To n)
    f(n) = strFile
    strFile = Dir()
  Wend
  
  File = f
  GetJPGs = n
  
  Erase f
  
End Function

'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

Trifft das die Problematik?