Einzelne Dateien in Dateiliste umbenennen durch neuen Wert (Namen) aus einer Zelle

Sub RenameFiles()
    'Variablen  
    Dim cell As Range, strCurrentFilePath As String, strNewFilePath As String, fso As Object
    'Objekte  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    ' In aktuellem Sheet  
    With ActiveSheet
        'Ermittle belegte Zellen in Spalte B ab B5 und iteriere über sie  
        For Each cell In .Range("B5:B" & .Cells(Rows.Count, "B").End(xlUp).Row)  
            ' Ist der Dateiname nicht leer dann mach weiter  
            If cell.Value <> "" Then  
                'setze aktuellen Pfad mit Dateinamen zusammen Spalte 6 und 2  
                strCurrentFilePath = fso.BuildPath(cell.Offset(0, 4).Value, cell.Value)
                'setze neuen Pfad mit Dateinamen zusammen Spalte 6 und 9  
                strNewFilePath = fso.BuildPath(cell.Offset(0, 4).Value, cell.Offset(0, 7).Value)
                ' Wenn Datei existiert benenne sie um  
                If fso.FileExists(strCurrentFilePath) Then
                    On Error Resume Next
                    'Datei umbenennen  
                    fso.MoveFile strCurrentFilePath, strNewFilePath
                    'Im Fehlerfall Meldung ausgeben  
                    If Err.Number <> 0 Then
                        MsgBox "FEHLER:" & vbNewLine & "Quelle: " & strCurrentFilePath & vbNewLine & "Ziel: " & strNewFilePath & vbNewLine & Err.Description, vbExclamation, "Fehler beim umbenennen"  
                    End If
                End If
            End If
        Next
    End With
    Set fso = Nothing
End Sub