Help edit code vba move image to subfolder !!!

N

Nguyen Anh Dung

Board Regular
Joined
Feb 28, 2020
Messages
180
Office Version
  1. 2016
Platform
  1. Windows
i have picture as below:
i have folder Image: include folder and image
i want move image group 1-> folder: 20200921_22_014_TPThuanAn_GS103997
i want move image group 2-> folder: 20200921_22_014_TPThuanAn_GS203997
1610806938890.png


i have code as below:
Code: 
Public Sub Moveimage_360_1()

    Dim sourceFolder As String, FileName As String
    Dim destinationFolder As String, foundDestinationFolder As String
     Dim destinationFolder1 As String
    Dim missingFolders As String
    Dim NewFileName As String
    
    On Error Resume Next
    'sourceFolder = "D:\Vidu\"
    sourceFolder = Application.InputBox("Nhap duong dan: ")
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
     missingFolders = ""
    FileName = Dir(sourceFolder & "*.JPG")
    While FileName <> vbNullString
        If Right(FileName, 4) = ".JPG" Then
           
            destinationFolder = Left(FileName, Len(FileName) - 7) 
            foundDestinationFolder = Find_Subfolder(sourceFolder, destinationFolder)
        End If
                
       
        If foundDestinationFolder <> "" Then
           
                 
           NewFileName = Split(FileName, "_")(4)
                Name sourceFolder & FileName As foundDestinationFolder & NewFileName
        'Else
            '   missingFolders = missingFolders & vbCrLf & destinationFolder
           
        End If
        
        FileName = Dir
    Wend
    
    If missingFolders = "" Then
        MsgBox "Ho" & ChrW(224) & "n Th" & ChrW(224) & "nh !!!"
    Else
         MsgBox "Folder Khong Ton Tai" & vbCrLf & _
                missingFolders
    End If

End Sub
Private Function Find_Subfolder(FolderPath As String, subfolderName As String) As String

    Static fso As Object
    Dim FSfolder As Object, FSsubfolder As Object
   
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    Set FSfolder = fso.GetFolder(FolderPath)
     
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.SubFolders
        If UCase(FSsubfolder.Name) = UCase(subfolderName) Then
            Find_Subfolder = FSsubfolder.Path & "\"
        Else
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, subfolderName)
        End If
        If Find_Subfolder <> "" Then Exit For
    Next
    
End Function
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Sort by date Sort by votes
As I understand it, you want the *.JPG files whose first 8 characters are "GS103997" to be moved to the subfolder ending with same 8 characters, and similarly for the "GS203997" files.

Try this macro:
VBA Code: 
Public Sub Move_Files()

    Dim sourceFolder As String
    Dim subfoldersDict As Object
    Dim fileName As String
   
    sourceFolder = "C:\path\to\folder\"    'CHANGE THIS
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
   
    Set subfoldersDict = Get_Subfolders(sourceFolder)
   
    fileName = Dir(sourceFolder & "*.JPG")
    While fileName <> vbNullString
        If subfoldersDict.Exists(Left(fileName, 8)) Then
            Name sourceFolder & fileName As subfoldersDict(Left(fileName, 8)) & fileName
        End If
        fileName = Dir
    Wend
   
End Sub


'Returns a Dictionary of paths, with last 8 characters as the keys, of subfolders in the specified folder

Private Function Get_Subfolders(ByVal folderPath As String) As Object

    Dim fileName As String
   
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
   
    Set Get_Subfolders = CreateObject("Scripting.Dictionary")
    fileName = Dir(folderPath, vbDirectory)
    While fileName <> vbNullString
        If (GetAttr(folderPath & fileName) And vbDirectory) <> 0 Then
            If fileName <> "." And fileName <> ".." Then
                Get_Subfolders.Add Right(fileName, 8), folderPath & fileName & "\"
            End If
        End If
        fileName = Dir
    Wend
       
End Function
 
Upvote 0
John_w said:
As I understand it, you want the *.JPG files whose first 8 characters are "GS103997" to be moved to the subfolder ending with same 8 characters, and similarly for the "GS203997" files.

Try this macro:
VBA Code: 
Public Sub Move_Files()

    Dim sourceFolder As String
    Dim subfoldersDict As Object
    Dim fileName As String
  
    sourceFolder = "C:\path\to\folder\"    'CHANGE THIS
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
  
    Set subfoldersDict = Get_Subfolders(sourceFolder)
  
    fileName = Dir(sourceFolder & "*.JPG")
    While fileName <> vbNullString
        If subfoldersDict.Exists(Left(fileName, 8)) Then
            Name sourceFolder & fileName As subfoldersDict(Left(fileName, 8)) & fileName
        End If
        fileName = Dir
    Wend
  
End Sub


'Returns a Dictionary of paths, with last 8 characters as the keys, of subfolders in the specified folder

Private Function Get_Subfolders(ByVal folderPath As String) As Object

    Dim fileName As String
  
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
  
    Set Get_Subfolders = CreateObject("Scripting.Dictionary")
    fileName = Dir(folderPath, vbDirectory)
    While fileName <> vbNullString
        If (GetAttr(folderPath & fileName) And vbDirectory) <> 0 Then
            If fileName <> "." And fileName <> ".." Then
                Get_Subfolders.Add Right(fileName, 8), folderPath & fileName & "\"
            End If
        End If
        fileName = Dir
    Wend
      
End Function
Click to expand...
Thanks John_w so much!!! Great nice!!!
In this case: i want move as below picture you can help edit code.
move: D:\Image\->e:\Test\Image_test\ include folder:
20200921_22_014_TPThuanAn_GS103997
20200921_22_014_TPThuanAn_GS203997


1610877841508.png

best regards,
Nguyen Anh Dung
 
Upvote 0
Was my understanding correct? Your first image shows that the destination subfolders are in the same folder as the .JPG files, which is what my first macro expects.

However now your image shows that the destination folders are subfolders of a specific folder (e:\Test\Image_test), which is separate from the source folder containing the .JPG files (d:\Image).

Try this new macro:
VBA Code: 
Public Sub Move_Files2()

    Dim sourceFolder As String, destinationFolder As String
    Dim subfoldersDict As Scripting.Dictionary
    Dim fileName As String
    
    sourceFolder = "d:\Image\"             'folder containing the .jpg files
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    
    destinationFolder = "e:\Test\Image_test\"      'folder containing the destination subfolders
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
    
    Set subfoldersDict = Get_Subfolders(destinationFolder)
    
    fileName = Dir(sourceFolder & "*.JPG")
    While fileName <> vbNullString
        If subfoldersDict.Exists(Left(fileName, 8)) Then
            Name sourceFolder & fileName As subfoldersDict(Left(fileName, 8)) & fileName
        End If
        fileName = Dir
    Wend
    
End Sub


'Returns a Dictionary of paths, with last 8 characters as the keys, of subfolders in the specified folder

Private Function Get_Subfolders(ByVal folderPath As String) As Dictionary

    Dim fileName As String
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    Set Get_Subfolders = New Dictionary
    fileName = Dir(folderPath, vbDirectory)
    While fileName <> vbNullString
        If (GetAttr(folderPath & fileName) And vbDirectory) <> 0 Then
            If fileName <> "." And fileName <> ".." Then
                Get_Subfolders.Add Right(fileName, 8), folderPath & fileName & "\"
            End If
        End If
        fileName = Dir
    Wend
        
End Function
 
Upvote 0
John_w said:
Was my understanding correct? Your first image shows that the destination subfolders are in the same folder as the .JPG files, which is what my first macro expects.

However now your image shows that the destination folders are subfolders of a specific folder (e:\Test\Image_test), which is separate from the source folder containing the .JPG files (d:\Image).

Try this new macro:
VBA Code: 
Public Sub Move_Files2()

    Dim sourceFolder As String, destinationFolder As String
    Dim subfoldersDict As Scripting.Dictionary
    Dim fileName As String
   
    sourceFolder = "d:\Image\"             'folder containing the .jpg files
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
   
    destinationFolder = "e:\Test\Image_test\"      'folder containing the destination subfolders
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
   
    Set subfoldersDict = Get_Subfolders(destinationFolder)
   
    fileName = Dir(sourceFolder & "*.JPG")
    While fileName <> vbNullString
        If subfoldersDict.Exists(Left(fileName, 8)) Then
            Name sourceFolder & fileName As subfoldersDict(Left(fileName, 8)) & fileName
        End If
        fileName = Dir
    Wend
   
End Sub


'Returns a Dictionary of paths, with last 8 characters as the keys, of subfolders in the specified folder

Private Function Get_Subfolders(ByVal folderPath As String) As Dictionary

    Dim fileName As String
   
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
   
    Set Get_Subfolders = New Dictionary
    fileName = Dir(folderPath, vbDirectory)
    While fileName <> vbNullString
        If (GetAttr(folderPath & fileName) And vbDirectory) <> 0 Then
            If fileName <> "." And fileName <> ".." Then
                Get_Subfolders.Add Right(fileName, 8), folderPath & fileName & "\"
            End If
        End If
        fileName = Dir
    Wend
       
End Function
Click to expand...
Hi John_w , Yes it works perfect. Thank you for your support!!!
Best regards,
Nguyen Anh Dung
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
Macro to move csv files within-subfolder to folder "Old Templates"
Replies
2
Views
371
howard
H
K
  • Locked
  • Question
VBA Code to move subfolders and all files from source folder to destination folder
Replies
1
Views
883
Peter_SSs
Peter_SSs
H
  • Question
Macro to Cut and Paste Files containing name "Purchase Ledger" from one folder to another
Replies
4
Views
318
howard
H
M
  • Solved
"invalid procedure call or argument"
2
Replies
13
Views
579
Mr_Ragweed2
M
M
  • Question
"Bad path or filename" runtime error 52 - sharepoint pathway issue
2
Replies
11
Views
961
Mr_Ragweed2
M

Forum statistics

Threads
1,214,823
Messages
6,121,780
Members
449,049
Latest member
greyangel23

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top