Move Files To Dynamic Folders Based On Cell Value

[wells]

Im not sure this is still possible... I referred few posts but they dont work with current office edition..

I have a folder with say around 100 excel workbooks. I need a macro to

1. Open each file in the directory specified
2. Read the contents of a particular cell, E8
3. Create a folder in the same directory with the value of E8
4. And, move the excel workbook itself to that folder.
5. Then it opens the next file
6. If the value of E8 is the same as that in the first workbook, it simply moves it to the already created folder, else it creates another folder with the new value of E8 and moves it there.


Note: The files are not always saved in a static file path.

 

[Joe4]

Try this code. Just update the folder location where the original files reside at the top of the code.

Sub MyMoveMacro()

    Dim fldr As String
    Dim wb As Workbook
    Dim newFldr As String
    Dim newFldrExists As String
    
    Dim oFile As Object
    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFiles As Object
    
'   ***** ENTER DIRECTORY OF FILES TO PROCESS *****
    fldr = "C:\Temp\Files"
        
'   Set file system objects
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(fldr) 'Initialize folder
    Set oFiles = oFolder.Files

    Application.ScreenUpdating = False

'   Loop through all Excel files in the folder
    For Each oFile In oFiles
        If (oFile Like "*.xls*") Then
'           Open file
            Set wb = Workbooks.Open(Filename:=oFile)
'           Get new folder name from cell E8
            newFldr = Range("E8").Value
            If Right(newFldr, 1) <> "\" Then newFldr = newFldr & "\"
'           Check to see if folder exists
            newFldrExists = Dir(newFldr, vbDirectory)
            If newFldrExists = "" Then
'               Create new directory
                MkDir newFldr
            End If
'           Save file to new directory
            wb.SaveAs Filename:=newFldr & wb.Name
'           Close workbook
            wb.Close
        End If
    Next oFile
    
'   Delete Excel files in original location
    If Right(fldr, 1) <> "\" Then fldr = fldr & "\"
    Kill fldr & "*.xls*"
        
    Application.ScreenUpdating = True
    
    MsgBox "Macro Complete!"
           
End Sub

 

[wells]

Hi , is it possible to choose the folder everytime I run the macro?

 

[Joe4]

OK, we can incorporate Fluff's code from here: Looking for a Macro to browse for a folder
like this:

Sub MyMoveMacro()

    Dim fpick As Object
    Dim fldr As String
    Dim wb As Workbook
    Dim newFldr As String
    Dim newFldrExists As String
    
    Dim oFile As Object
    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFiles As Object
        
    Application.ScreenUpdating = False

'   Browse for folder
    Set fpick = Application.FileDialog(4)
    With fpick
       .Title = "Select a Folder"
       .AllowMultiSelect = False
       If .Show <> -1 Then Exit Sub
       fldr = .SelectedItems(1)
    End With
        
'   Set file system objects
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(fldr) 'Initialize folder
    Set oFiles = oFolder.Files

'   Loop through all Excel files in the folder
    For Each oFile In oFiles
        If (oFile Like "*.xls*") Then
'           Open file
            Set wb = Workbooks.Open(Filename:=oFile)
'           Get new folder name from cell E8
            newFldr = Range("E8").Value
            If Right(newFldr, 1) <> "\" Then newFldr = newFldr & "\"
'           Check to see if folder exists
            newFldrExists = Dir(newFldr, vbDirectory)
            If newFldrExists = "" Then
'               Create new directory
                MkDir newFldr
            End If
'           Save file to new directory
            wb.SaveAs Filename:=newFldr & wb.Name
'           Close workbook
            wb.Close
        End If
    Next oFile
    
'   Delete Excel files in original location
    If Right(fldr, 1) <> "\" Then fldr = fldr & "\"
    Kill fldr & "*.xls*"
        
    Application.ScreenUpdating = True
    
    MsgBox "Macro Complete!"
           
End Sub

 

[wells]

Hi Joe , Im sorry but I get this error

 

[wells]

when debugged the error is at

wb.SaveAs Filename:=newFldr & wb.Name

 

[Joe4]

Did you check/verify the three possible reasons listed, to make sure that you don't meet any of those conditions?

 

[wells]

yes... there is no such problems except for the 3rd point im not sure as it depends on the code you have given.

 

[Joe4]

yes... there is no such problems except for the 3rd point im not sure as it depends on the code you have given.

That is pretty simple to test. Just check to see if you have any other Excel files open at that time, with the same name as the file it is trying to save.
Or, if there is a file with that name already, see if you can go into the folder and open it up. If it is already opened by someone else, you should get a message letting you know that the file is already open elsewhere.

When you get this error, does it happen on the first pass, or does it process a few files before this error occurs?

 

[wells]

no.. the first file itself gives this error before creating a folder. ill just brief what I did.. .I created a bank excel file inserted a module and then pasted this code. saved the file in desktop. then ran the macro.. chose the folder and then this error pops. while I executed no other file was open except this file and no file is duplicated