シート上の情報からファイル名を変更

Sub prcRenameFilesWithFullPath()
     
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    
    Dim strOldFullPath As String
    Dim strNewFullPath As String
    Dim lngLastRow As Long
    Dim lngRow As Long
    Dim bFileIsOpen As Boolean
    
    With ActiveSheet
        lngLastRow = .Cells(.Rows.Count, "F").End(xlUp).Row ' F列を基準に最後の行を取得
    End With
    
    For lngRow = 2 To lngLastRow
        With ActiveSheet
            strOldFullPath = .Cells(lngRow, 6).Value ' F列から変更前のフルパスを取得
            strNewFullPath = .Cells(lngRow, 7).Value ' G列から変更後のフルパスを取得
            
            ' ファイルが開かれているかチェック
            If IsFileOpen(strOldFullPath) Then
                bFileIsOpen = True
                Exit For
            End If
        End With
    Next lngRow
    
    If bFileIsOpen Then
        ' 開かれているファイルがある場合は警告メッセージを表示し、処理を中止
        MsgBox "一つ以上のファイルが開かれています。処理を中止します。", vbExclamation
        Exit Sub
    Else
        ' ファイル名を変更する
        For lngRow = 2 To lngLastRow
            With ActiveSheet
                strOldFullPath = .Cells(lngRow, 6).Value
                strNewFullPath = .Cells(lngRow, 7).Value
                
                If fso.FileExists(strOldFullPath) Then
                    fso.MoveFile Source:=strOldFullPath, Destination:=strNewFullPath
                Else
                    MsgBox "File not found: " & strOldFullPath, vbExclamation
                End If
            End With
        Next lngRow
    End If
    
    Set fso = Nothing
End Sub

Function IsFileOpen(ByVal strFileName As String) As Boolean
    Dim intFileNum As Integer
    Dim bRetVal As Boolean
    On Error Resume Next
    intFileNum = FreeFile()
    Open strFileName For Input Lock Read As #intFileNum
    If Err.Number <> 0 Then
        bRetVal = True
    Else
        bRetVal = False
        Close #intFileNum
    End If
    On Error GoTo 0
    IsFileOpen = bRetVal
End Function