Move files to diff folders based on filename

Option Explicit

Sub MoveFiles()
'JBeaucaire  (2/6/2010)
'Moves files from the desktop into folders of their own
Dim fName As String, fromPath As String, toPath As String, Cnt As Long
On Error Resume Next

toPath = "C:\Test1\"
fromPath = "C:\Documents and Settings\Jerry\Desktop\"

Restart:
If Cnt > 1 Then Exit Sub
fName = Dir(fromPath & "*.xls")

Do While Len(fName) > 0
    If Cnt > 1 Then Exit Sub
    Cnt = 0
    If Len(Dir(toPath & Left(fName, Len(fName) - 4), vbDirectory)) = 0 Then
        MkDir toPath & Left(fName, Len(fName) - 4)
    End If
    Name (fromPath & fName) As (toPath & Left(fName, Len(fName) - 4) & "\" & fName)
    fName = Dir
Loop

Cnt = Cnt + 1
GoTo Restart

End Sub

Option Explicit

Sub MoveFiles()
'JBeaucaire  (4/8/2010)
'Moves files from the desktop into folders of their own
'Create subfolders as needed based on first 3 characters of each filename
Dim fName As String, fromPath As String, toPath As String
Dim toSubPath As String, Cnt As Long
On Error Resume Next

toPath = "C:\Test1\"
fromPath = "C:\2010\"

Restart:
If Cnt > 1 Then Exit Sub
fName = Dir(fromPath & "*.pdf")

Do While Len(fName) > 4
    If Cnt > 1 Then Exit Sub
    Cnt = 0
    toSubPath = toPath & Left(fName, 3) & "\"
    If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath
    Name (fromPath & fName) As (toSubPath & fName)
    fName = Dir
Loop

Cnt = Cnt + 1
GoTo Restart

End Sub