Move File to Folder if filename matches foldername

[Jill]

Hi All,

Im fairly new to excel macros. I have some scripting experience in other programs but I would consider myself a noob.

Just for transparency purposes, I've tried to do this in another application and failed. So I'm switching to excel
http://www.vbaexpress.com/forum/show...-to-SubFolders

I have a Directory that includes Folders and Files. If the Filename contains the Foldername I want to move the file into its respective folder.

I've made numerous attempts. I hope someone out there can advise me on what I'm doing wrong. Thanks in advance

Jill

Code is below.... Also including a screenshot of the directory for clarity. Also I left in some of the attempts within the code but commented them out.

At this line i get this error
FSO.Movefile Source:=SourceFileName, Destination:=DestinFileName
run-time error '5':
Invalid procedure call or argument

Sub FileSort()

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim MyFolder As String
Dim MyFile As String
Dim directory As String
Dim i As Integer
Dim FSO As Object
Dim File
Dim Folder
Dim Fldr
Dim SourceFileName As String
Dim DestinFileName As String

''THIS CHECKS TO SEE IF FILE EXISTS...THIS WORKED
'File = Dir("C:\Rendermation\Renders\*.png")
'MsgBox FileEnd Sub

''THIS CHECKS TO SEE IF A FOLDER EXISTS AND IF NOT, CREATES THE FOLDER....THIS WORKED
'Folder = "C:\Rendermation\Renders\*.3dm"
'Fldr = Dir(Folder, vbDirectory)
'If Len(Fldr) > 0 Then
' MsgBox (Fldr & " Already Exists")
'Else
' MkDir Folder
' MsgBox ("Folder Created")
' End If
'End Sub


Folder = "C:\Rendermation\Renders\*.3dm"
Fldr = Dir(Folder, vbDirectory)
File = Dir("C:\Rendermation\Renders\*.png")

Set FSO = CreateObject("Scripting.Filesystemobject")
SourceFileName = "C:\Rendermation\Renders\perspective_" & (Folder) & ".png"
DestinFileName = "C:\Rendermation\Renders\" & (Folder)

FSO.Movefile Source:=SourceFileName, Destination:=DestinFileName 'THIS IS THE LINE THAT ERRORS
MsgBox (SourceFileName + " Moved to " + DestinFileName)

'FSO.Movefile "C:\Rendermation\Renders\perspective_" & (Folder) & ".png", "C:\Rendermation\Renders\" & (Folder) 'THIS LINE ALSO ERRORS
'End If

End Sub

[mdmackillop]

Please use code tags or # button when you post code.
Is this thread of use?

[Jill]

Thanks for the reply and suggested link!

I tried to decipher and apply the info from manas thread. I am having trouble for a few reasons.
1. I cant figure out how to bypass the folder picker, the location of the folders will always be the same. the name of the folder will always change.
2. I read up on Mid but cant figure out how to apply, In my example, the beginning of the filename is the variable

My source files are always .png and are always located here.
C:\Rendermation\Renders\

My destination folder is titled with the filename
C:\Rendermation\Renders\filename *Note no view and no .png

The structure for the source files is this always
view_filename.png

The view with filename can be one of the following
bluestone_filename.png
perspective_filename.png
side_filename.png
throughfingerangle_filename.png
topangle_filename.png


Below is my attempts after trying to apply the info from manas thread.

Sub FileSort()


'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual






    Dim MyFolder As String
    Dim directory As String
    Dim i As Integer
    Dim fso As Object
    Dim myFile As String
    Dim FolderName As String
    Dim pFldr As String
    Dim cFldr As String
    Dim SubFolder As String
    Dim MyName As String
    Dim View As String
    Dim Name1 As String




   
FolderName = "C:\Rendermation\Renders\*.3dm"
myFile = "C:\Rendermation\Renders\*.png"
View = "C:\Rendermation\Renders\*" & (myFile)
pFldr = Dir(FolderName, vbDirectory)
MyName = Dir(View & myFile)




Do While myFile <> ""


       cFldr = Dir("C:\Rendermation\Renders\")
       Name MyName & FolderName As pFldr & cFldr & "\"
       myFile = Dir()
        
    Loop
End Sub

[mdmackillop]

Hi Jill
This will show proposed file moves in the immediate window. If you're happy with that, uncomment the Name line to move the files.

Sub GetFolders()
pth = "C:\Rendermation\Renders\"
fldlst = Split(CreateObject("wscript.shell").exec("cmd /c Dir " & pth & "*. /b /s").stdout.readall, vbCrLf)
For Each f In fldlst
If f <> "" Then MoveFiles Split(f, "\")(UBound(Split(f, "\"))), f, pth
Next
End Sub


Sub MoveFiles(Fld, f, pth)
fpth = pth & "*" & Fld & "*.png"
lst = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & fpth & " /b /a-d").stdout.readall, vbCrLf), ".")
For Each l In lst
Debug.Print pth & l & " ===> " & f & "\" & l
'Name pth & l As f & "\" & l   'Remove comment to run
Next
End Sub

[mdmackillop]

More "conventional"

Sub FileSort()
    Dim i&, col As New Collection
    Folder = "C:\Rendermation\Renders\"
    MyName = Dir(Folder, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            If (GetAttr(Folder & MyName) And vbDirectory) = vbDirectory Then
                col.Add MyName
            End If
        End If
        MyName = Dir()
    Loop
    
    For Each c In col
        File = Dir(Folder & "*" & c & "*.png")
        Do
        Source = Folder & File
        Target = Folder & MyName & c & "\" & File
        Debug.Print Source & " ===> " & Target
         'Name Source As Target    'Remove comment to run
        File = Dir()
        Loop Until File = ""
    Next c
    
End Sub

[Jill]

Hi again mdmackillop!

I've tested your script on over 1000 images and it worked perfectly.

Initially I had a random folder in the root directory and it gave me troubles. Once I removed that folder, it moved all the files.

Really, really appreciate the help. I realize I'm a noob trying to do more advanced stuff. I'm grateful for your generosity.

Jill