asked on

Script to Move files into subfolders

I have a directory with over 30,000 files in it and windows explorer freaks out everytime I try to go into the directory.

My solution is to move every file in a folder by the first letter of the file name.

In other words, move all the files a*.* to C:\MYFILES\A and move b*.* to C:\MYFILES\B

I suppose I could write a 26 line batch script, one for every letter, and maybe another for characters and 10 more for numbers...but maybe somebody knows a cleaner way to do this?

Lycaon

Here's a possible solution. Still a bit bulky, but it's still shorter, and reusable.

Sub SortFolder(sFolder As String) ' sFolder MUST end in a "\"
Dim x As Integer, Files() As String, Folder As String, CurrentFile As String

' Create all folders first, a-z
For x = Asc("a") To Asc("z")
Directory.CreateDirectory(sFolder & Chr(x) & "\")
Next

' Create numbered folders, 0-9
For x = 0 To 9
Directory.CreateDirectory(sFolder & CStr(x) & "\")
Next

' Create a folder for any non-number, non-alpha file (!, @, etc)
Directory.CreateDirectory(sFolder & "Misc\")

Files = Directory.GetFiles(sFolder) ' Gets all files. The entire path of the file is returned in an array, one path+file per spot

For x = 0 To Files.Length - 1 ' Loop through all files
CurrentFile = Files(x).Substring(Files(x).LastIndexOf("\") + 1) ' Finds the last "\" in the path and extracts the filename from it
Folder = CurrentFile.Substring(0, 1) ' Get the first character of the file, used to sort into folders

Select Case Folder.ToLower ' Decide based on the first character of the filename

Case "a" To "z", "0" To "9" ' Move to the correct folder
File.Move(Files(x), sFolder & Folder & "\" & CurrentFile)

Case Else
File.Move(Files(x), sFolder & "Misc\" & CurrentFile)

End Select

Next
End Sub

Lycaon

Oh, the case else is to deal with any file that does not start with a letter or number

Lycaon

Ack, I also forgot to mention you'll need to import System.IO :x

DVation191

ASKER

" Ack, I also forgot to mention you'll need to import System.IO :x"
> I'm afriad I don't know how to do that....can you explain?

Lycaon

I'm sorry DVation191, I thought I was looking in the VB.NET section. That' won't work as a regular script :|

DVation191

ASKER

that explains this error...
lol...oh well...it looked so promising...wanna compile it into an exe and send it to me? lol

rename.vbs(1, 24) Microsoft VBScript compilation error: Expected ')'

ADSaunders

Hi DVation191 ,
This is a vbscript to do what you want, just copy & paste into a .vbs file (e.g. MoveFiles.vbs) and run it.

Regards .. Alan

private const SourcePath = "c:\" ' put your source directory here
private const DestPath = "c:\ByAlpha\" ' put your destination directory here
private sub HandleFile (byval f)
Dim init
      ' Get the fist letter of the name (Doesn't matter what it is as long as it's printable)
      init = left(f.name, 1)
'check whether the folder exists
      if not fso.FolderExists(DestPath & init) then
            fso.createfolder(DestPath & init)
      end if
      ' If SourcePath and Destpath are on the same volume, or if the OS supports moving across volumes
      fso.MoveFile f.Path, DestPath & init
      ' Otherwise you might need:
      ' Fso.CopyFile f.Path, DestPath & init
      ' Fso.DeleteFile f.Path
end sub

Private Sub handlefolder(ByVal folder)
' Only need this to recurse subdirectories in the source path
' For Each f In folder.SubFolders ' may not be necessary if there are no subfoldrs to recurse
' handlefolder f ' '' ''
' Next ' '' ''
for each f in folder.files
handlefile f
next
End Sub

' Main Routine starts here
Dim fso, fo, fw, fr, glub
Set fso = CreateObject("Scripting.filesystemobject")
' Get handle to input folder
Set fo = fso.GetFolder(SourcePath)
handlefolder fo
Set fso = Nothing
Set fo = Nothing

ADSaunders

Hi,
You can't tell this was hacked from another script can you? .. You don't need the dim's for fw, fr, glub, only Dim fso, fo.
Sorry

.. Alan

DVation191

ASKER

I edited the script accordingly....

private const SourcePath = "C:\DOWNLOADS\Font Collection\Copy of OpenType Fonts" ' put your source directory here
private const DestPath = "C:\DOWNLOADS\Font Collection\Copy of OpenType Fonts\Alpha" ' put your destination directory here
private sub HandleFile (byval f)
Dim init
' Get the fist letter of the name (Doesn't matter what it is as long as it's printable)
init = left(f.name, 1)
'check whether the folder exists
if not fso.FolderExists(DestPath & init) then
fso.createfolder(DestPath & init)
end if
' If SourcePath and Destpath are on the same volume, or if the OS supports moving across volumes
fso.MoveFile f.Path, DestPath & init
' Otherwise you might need:
' Fso.CopyFile f.Path, DestPath & init
' Fso.DeleteFile f.Path
end sub

Private Sub handlefolder(ByVal folder)
' Only need this to recurse subdirectories in the source path
' For Each f In folder.SubFolders ' may not be necessary if there are no subfoldrs to recurse
' handlefolder f ' '' ''
' Next ' '' ''
for each f in folder.files
handlefile f
next
End Sub

' Main Routine starts here
Dim fso, fo
Set fso = CreateObject("Scripting.filesystemobject")
' Get handle to input folder
Set fo = fso.GetFolder(SourcePath)
handlefolder fo
Set fso = Nothing
Set fo = Nothing

However it generates an error I can't debug.
"rename.vbs(12, 6) Microsoft VBScript runtime error: File already exists"

ADSaunders

Hi,
>private const SourcePath = "C:\DOWNLOADS\Font Collection\Copy of OpenType Fonts" ' put your source directory here
>private const DestPath = "C:\DOWNLOADS\Font Collection\Copy of OpenType Fonts\Alpha" ' put your destination directory here

You're missing the trailing '\' on the paths!

.. Alan

DVation191

ASKER

doh! sorry!

Ok I added the '\' at the end of the paths and ran it again. same error.

I tried deleting the 'C:\DOWNLOADS\Font Collection\Copy of OpenType Fonts\Alpha\' folder and ran it...got this error...
rename.vbs(9, 11) Microsoft VBScript runtime error: Path not found

So I'll assume 'C:\DOWNLOADS\Font Collection\Copy of OpenType Fonts\Alpha\' needs to be created...so I left Alpha there. But I'm still getting path not found errors...really sorry if I'm missing something stupid here!

Then i tried moving the rename.vbs to a directory outside of 'Copy of OpenType Fonts' and got this error...
rename.vbs(12, 6) Microsoft VBScript runtime error: File already exists

ADSaunders

Hi,
A bit more .. I've actually run this now. Modify Sub HandleFile to the following: (as well as adding trailing '\' to the paths).

.. Alan

private sub HandleFile (byval f)
Dim init
' Get the fist letter of the name (Doesn't matter what it is as long as it's printable)
init = left(f.name, 1)
'check whether the folder exists
if not fso.FolderExists(DestPath & init) then
fso.createfolder(DestPath & init)
end if
' If SourcePath and Destpath are on the same volume, or if the OS supports moving across volumes
fso.MoveFile f.Path, DestPath & init & "\" & f.Name ' Seems FSO.MoveFile needs the actual file name, not just the path
' Otherwise you might need:
' Fso.CopyFile f.Path, DestPath & init
' Fso.DeleteFile f.Path
end sub

ASKER CERTIFIED SOLUTION

ADSaunders

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

DVation191

ASKER

I ran it on two small font folders and it worked beautifully. I am running it on a folder now with over 30,000 files and its taking a while but working great....thanks!!!!

DVation191

ASKER

could be tweaked just a hair (make all the characters of the folders created use uppercase instead of whatever the case is of the first letter in the alpha)....but otherwise it works flawlessly.

thanks!