VBA to create folders and copy files based on file names

[Ross12345]

Hi experts,

Hope someone can help with this. I have 10k images named as AA-1000.jpg or AA-1000-10.jpg etc. The important thing is that I want to create folders based on first 2 letters in image names, and move all other images with same letters to the same folder.

Basically, I want to run a VBA for all images located in one folder.
So, all images below will go to AA folder:
AA-1500.jpg
AA-1000-41.jpg
AA-1005.jpg
AA-1000.jpg
AA-1000-S2.jpg
AA-1045.jpg

These images will go to AB folder:
AB-10452.jpg
AB-10800.jpg
AB-10700.jpg
AB-10080.jpg

etc.

Folders need to be created by VBA too. Is this doable?

 

[ParamRay]

can do it this way

Public Sub MoveImages()
' Source directory is where original jpg files are stored.
' Target directory is where subfolders will be created
' into which the source files will be moved.
  Const strSOURCE_DIR = "C:\Users\MyUserName\Pictures\"
  Const strTARGET_DIR = "C:\Users\MyUserName\Documents\"
  
  Dim strSourcePath As String
  Dim strTargetPath As String
  Dim strSubfolder As String
  Dim strFilename As String
  Dim strMessage As String
  Dim strErrors As String
  Dim lngCounter As Long
  
' Get first jpg file in source directory
  On Error GoTo ErrHandler
  strFilename = Dir(strSOURCE_DIR & "*.jpg")
  
  Do While strFilename <> ""
    strSourcePath = strSOURCE_DIR & strFilename
    strSubfolder = strTARGET_DIR & Left(strFilename, 2)
    strTargetPath = strSubfolder & "\" & strFilename
    
  ' Create subfolder if it doesn't already exist
    On Error Resume Next
    MkDir strSubfolder
    If Err.Number <> 0 Then Err.Clear
  
  ' Move source file to new location
    Name strSourcePath As strTargetPath
    
  ' If an error occurred, log it to error list
    If Err.Number <> 0 Then
      If strErrors <> "" Then strErrors = strErrors & ", "
      strErrors = strErrors & strFilename
    Else
      lngCounter = lngCounter + 1
    End If
    
  ' Move onto next jpg file
    On Error GoTo ErrHandler
    strFilename = Dir()
  Loop
  
' Notify user of results, including any errors
  strMessage = "Transfer of " & lngCounter & " files was completed."
  If strErrors <> "" Then
    strMessage = strMessage & vbCrLf & vbCrLf
    strMessage = strMessage & "These files were unsuccessful:"
    strMessage = strMessage & vbCrLf & strErrors
  End If
  MsgBox strMessage, vbInformation
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation
End Sub

 

[Ross12345]

Thanks a lot!!! It works!

 

[Jojo Dthird]

I'm also interested in this but I want to copy files matching the folder name from a database and loops until all folders are searched and copies into one folder.

I'm new in VBA.

Thanks.

 

[Nguyen Anh Dung]

can do it this way

Public Sub MoveImages()
' Source directory is where original jpg files are stored.
' Target directory is where subfolders will be created
' into which the source files will be moved.
  Const strSOURCE_DIR = "C:\Users\MyUserName\Pictures\"
  Const strTARGET_DIR = "C:\Users\MyUserName\Documents\"
 
  Dim strSourcePath As String
  Dim strTargetPath As String
  Dim strSubfolder As String
  Dim strFilename As String
  Dim strMessage As String
  Dim strErrors As String
  Dim lngCounter As Long
 
' Get first jpg file in source directory
  On Error GoTo ErrHandler
  strFilename = Dir(strSOURCE_DIR & "*.jpg")
 
  Do While strFilename <> ""
    strSourcePath = strSOURCE_DIR & strFilename
    strSubfolder = strTARGET_DIR & Left(strFilename, 2)
    strTargetPath = strSubfolder & "\" & strFilename
   
  ' Create subfolder if it doesn't already exist
    On Error Resume Next
    MkDir strSubfolder
    If Err.Number <> 0 Then Err.Clear
 
  ' Move source file to new location
    Name strSourcePath As strTargetPath
   
  ' If an error occurred, log it to error list
    If Err.Number <> 0 Then
      If strErrors <> "" Then strErrors = strErrors & ", "
      strErrors = strErrors & strFilename
    Else
      lngCounter = lngCounter + 1
    End If
   
  ' Move onto next jpg file
    On Error GoTo ErrHandler
    strFilename = Dir()
  Loop
 
' Notify user of results, including any errors
  strMessage = "Transfer of " & lngCounter & " files was completed."
  If strErrors <> "" Then
    strMessage = strMessage & vbCrLf & vbCrLf
    strMessage = strMessage & "These files were unsuccessful:"
    strMessage = strMessage & vbCrLf & strErrors
  End If
  MsgBox strMessage, vbInformation
  Exit Sub
 
ErrHandler:
  MsgBox Err.Description, vbExclamation
End Sub

Hi ParamRay!!!
great nice!!! in this case i only want copy file then edit code?
Thanks best regards!!!