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:

0PD804_FT
0PD804_BK

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.

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.

Code:

---

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

---