Set dupRange = Range("B5:B33000")
        dupSearch = Cells(r, 2) 

        Set dup = dupRange.Find(dupSearch)
            If dup Is Nothing Then
                Resume Next
            End If

Sub List_Files()
Dim MyFolder As String
Dim MyFile As String
Dim a As Integer

'Date Created Object
Dim oFS As Object

MyFolder = (Cells(2, 2).Value2 & "\")
MyFile = Dir(MyFolder & "*.*")
a = 4

Do While MyFile < ""
    a = a + 1
    Cells(a, 1).Value = MyFile
    
    'Date Modified code:
    Set oFS = CreateObject("Scripting.FileSystemObject")
    
    Cells(a, 3).Value = oFS.GetFile(MyFolder & MyFile).DateLastModified
    
    Set oFS = Nothing
    
    'End of Date Modified code
    
    MyFile = Dir
    Cells(3, 5).Value = a - 4
Loop
MsgBox "Success. Files imported: " & (a - 4)

End Sub

Sub ReName_Files()
On Error GoTo ErrHandler:
Dim MyFolder As String
Dim MyFile As String
Dim r As Integer
Dim e As Integer
Dim we As Integer
Dim d As Integer
Dim dupSearch As String
Dim dup As Range
Dim dupRange As Range

'Definition of counters
d = 0
e = 0
we = 0
'Folder locations
MyFolder = (Cells(2, 2).Value2 & "\")
MyFile = Dir(MyFolder & "*.*")
'Counter variable
r = 5

'Loop Through until cells are empty
Do Until IsEmpty(Cells(r, 1)) Or IsEmpty(Cells(r, 2))
    
    ' Short name (usually excluding number) catch
    If Len(Cells(r, 1)) < 14 Then
        e = e + 1
        Cells(12, 5).Value = e
        Cells(e + we + d + 2, 6).Value = Cells(r, 1) & " (Name is too short)"
        Cells(r, 4).Value = Cells(r, 4).Value & "Short Name "
    End If
    
    ' Catch for non pdf files
    If UCase(Cells(r, 12).Value) < "PDF" Then
        we = we + 1
        Cells(9, 5).Value = we
        Cells(e + we + d + 2, 6).Value = Cells(r, 1) & " (Not a PDF)"
        Cells(r, 4).Value = Cells(r, 4).Value & "Non PDF "
        Cells(r, 2).Value = Cells(r, 1).Value
    End If
    
    ' No underscore before last 9 digits in name
    If Cells(r, 14).Value < "_" Then
        e = e + 1
        Cells(12, 5).Value = e
        Cells(e + we + d + 2, 6).Value = Cells(r, 1) & " (Check name)"
        Cells(r, 4).Value = Cells(r, 4).Value & "Incorrect Format "
        Cells(r, 2).Value = Cells(r, 1).Value
        r = r + 1
    Else
' Renaming Code *IMPORTANT*
        Name MyFolder & Cells(r, 1).Value As MyFolder & Cells(r, 2).Value
        r = r + 1
        Cells(6, 5).Value = r - 5
    End If
    
Loop
MsgBox "All old file names in Column 'A' have now been renamed" & vbCr & _
        "to the adjacent new name in column 'B'." & vbCr & "Files renamed: " & (r - 5)
        
ErrHandler:
    If Err.Number = 58 Then
        
        '.Find solution
        d = d + 1
        Set dupRange = Range("B5:B33000")
        dupSearch = Cells(r, 2) '.Value
        MsgBox ("Duplicate Search is: " & dupSearch & " when r is: " & r & "The previous Cell is " & Cells(r - 1, 2))
        
        Set dup = dupRange.Find(dupSearch)
            If dup Is Nothing Then
                MsgBox ("Dup didn't find anything when r is: " & r)
                Resume Next
            Else
                MsgBox ("dup found: " & dup & " when r is: " & r)
            End If

        If Cells(r, 3).Value < dup.Offset(1, 0) Then
            Name MyFolder & Cells(r, 1).Value As MyFolder & "OLD" & d & "_" & Cells(r, 2).Value
            Name MyFolder & dup.Offset(0, -1) As MyFolder & "NEW" & d & "_" & dup
            Cells(15, 5).Value = d
            Cells(e + we + d + 2, 6).Value = "OLD" & d & "_" & Cells(r, 2) & " (Old Duplicate)"
            Cells(r, 4).Value = Cells(r, 4).Value & "Old Duplicate "
            Cells(r, 2).Value = "OLD" & d & "_" & Cells(r, 2).Value
            dup = "NEW" & d & "_" & dup
        Else
            Name MyFolder & Cells(r, 1).Value As MyFolder & "NEW" & d & "_" & Cells(r, 2).Value
            Name MyFolder & dup.Offset(0, -1) As MyFolder & "OLD" & d & "_" & dup
            Cells(15, 5).Value = d
            Cells(e + we + d + 2, 6).Value = "NEW" & d & "_" & Cells(r, 2) & " (New Duplicate)"
            Cells(r, 4).Value = Cells(r, 4).Value & "New Duplicate "
            Cells(r, 2).Value = "NEW" & d & "_" & Cells(r, 2).Value
            dup = "OLD" & d & "_" & dup
        End If
        
        Set dup = Nothing

        Resume Next
    End If
    
MsgBox Err.Description
    
End Sub

Dim dup As Object
        Set dupRange = Range("B5:B" & r - 1)
        dupSearch = Cells(r, 2)
            
        dupRange.Select
    
        Set dup = Selection.Find(What:=dupSearch, After:=ActiveCell, LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            If dup Is Nothing Then
                Resume Next
            End If