Move Files To Dynamic Folders Based On Cell Value

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
365, 2016
Platform
Windows
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.
 

Some videos you may like

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
53,410
Office Version
365
Platform
Windows
Try this code. Just update the folder location where the original files reside at the top of the code.
VBA 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

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
365, 2016
Platform
Windows
Hi , is it possible to choose the folder everytime I run the macro?
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
53,410
Office Version
365
Platform
Windows
OK, we can incorporate Fluff's code from here: Looking for a Macro to browse for a folder
like this:
VBA Code:
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

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
365, 2016
Platform
Windows
Hi Joe , Im sorry but I get this error

1589958578198.png
 

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
365, 2016
Platform
Windows
when debugged the error is at

VBA Code:
wb.SaveAs Filename:=newFldr & wb.Name
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
53,410
Office Version
365
Platform
Windows
Did you check/verify the three possible reasons listed, to make sure that you don't meet any of those conditions?
 

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
365, 2016
Platform
Windows
yes... there is no such problems except for the 3rd point im not sure as it depends on the code you have given.
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
53,410
Office Version
365
Platform
Windows
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

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
365, 2016
Platform
Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,099,036
Messages
5,466,161
Members
406,471
Latest member
tsou88

This Week's Hot Topics

Top