Move files from one folder to another and rename it, if the file exist then add number 1,2, etc in increment (VBA)

Public Sub Rename_and_Move_Files()

    Dim data As Variant
    Dim currentFolder As String, newFolder As String
    Dim CompanyCode As String, fileName As String
    Dim r As Long, n As Long, p As Long
   
    data = ActiveSheet.Range("A1").CurrentRegion.Value
   
    For r = 2 To UBound(data)
        CompanyCode = data(r, 1)
        currentFolder = data(r, 3)
        If Right(currentFolder, 1) <> "\" Then currentFolder = currentFolder & "\"
        newFolder = data(r, 4)
        If Right(newFolder, 1) <> "\" Then newFolder = newFolder & "\"
        n = 0
        fileName = Dir(currentFolder & "*.*")
        While fileName <> vbNullString
            n = n + 1
            p = InStrRev(fileName, ".")
            If InStr(fileName, "PO") Then
                Name currentFolder & fileName As newFolder & Format(Date, "yymmdd_") & CompanyCode & "_PO_" & n & Mid(fileName, p)
            Else
                Name currentFolder & fileName As newFolder & Format(Date, "yymmdd_") & CompanyCode & "_" & n & Mid(fileName, p)
            End If
            fileName = Dir
        Wend
    Next
   
    MsgBox "Done"
   
End Sub