Results 1 to 2 of 2

Thread: Sorting out JPEGS to seperate folders

  1. #1

    Sorting out JPEGS to seperate folders

    Not sure if i am in the right forum, but here is my idea.

    at work i have a couple hundred jpegs i have to sort out and put into folders. there are two of each for example:


    i would like to be able to put these in a folder and have the program look in the folder, then sort them out and create folders automatically to put them in.

    so those would go in a folder called 0PD804.

    im not sure how simple this is, im only proficient with VBA when it comes to excel, i've never really done anything like this. but some tips and pointers would be appreciated!

    thanks in advance.

  2. #2
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    May 2004
    Welcome to VBAX.
    Give this a try. Make sure that your Target folder location is not contained in the Source folder. If you need to search C: to locate all jpg files, the target will need to be excluded to avoid endless loop.
    Option Explicit
    Option Compare Text
    Dim LookingFor      As String
    Dim SourcePth         As String
    Dim TargetPth As String
    Sub SearchAll()
    Dim FSO As Object
    Dim Pth As String
    'Set options
    SourcePth = "C:\bbb\" '<=== Enter path containing jpg files
    TargetPth = "C:\aaa\"  '<=== Enter path to receive new folders
    LookingFor = "jpg"       'Process filter if required
    Set FSO = CreateObject("Scripting.FileSystemobject")
    Call ProcessFolder(FSO, SourcePth, True)
    Set FSO = Nothing
    End Sub
    Private Function ProcessFolder( ByRef FSO As Object, ByVal Foldername As String, Optional ByVal Init As Boolean)
    Dim Fldr As Object
    Dim SubFldr As Object
    Dim File As Object
    Set Fldr = FSO.GetFolder(Foldername)
    'Process head folder once only
    If Init = True Then
    For Each File In Fldr.Files
    ProcessFiles Fldr, File
    Next File
    End If
    On Error Resume Next
    For Each SubFldr In Fldr.SubFolders
    'Handle restricted folders  e.g Recylce Bin
    If Not Err = 70 Then
    For Each File In SubFldr.Files
    ProcessFiles SubFldr, File
    Next File
    Call ProcessFolder(FSO, SubFldr.Path)
    End If
    Next SubFldr
    'Clean up
     Set File = Nothing
     Set SubFldr = Nothing
     Set Fldr = Nothing
    End Function
    'Process details
    Sub ProcessFiles(Fld, f)
    Dim NewFolder   As String
    If f.Name Like "*" & LookingFor Then
    If InStr(f.Name, "-") > 0 Then
    NewFolder = TargetPth & Split(f.Name, "-")(0)
    On Error Resume Next
    MkDir NewFolder
    On Error GoTo 0
    Name f As NewFolder & "\" & f.Name
    End If
    End If
    End Sub
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.

    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts