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 (http://www.vbaexpress.com/forum/showthread.php?60432-Move-Files-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 (http://www.vbaexpress.com/forum/showthread.php?60416-Copy-and-Move-files-to-existing-Sub-folders-based-on-filename-Sub-folders-s-Name) 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