Move Files To Dynamic Folders Based On Cell Value

wells

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

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
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
 
Upvote 0
Hi , is it possible to choose the folder everytime I run the macro?
 
Upvote 0
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
 
Upvote 0
Hi Joe , Im sorry but I get this error

1589958578198.png
 
Upvote 0
when debugged the error is at

VBA Code:
wb.SaveAs Filename:=newFldr & wb.Name
 
Upvote 0
Did you check/verify the three possible reasons listed, to make sure that you don't meet any of those conditions?
 
Upvote 0
yes... there is no such problems except for the 3rd point im not sure as it depends on the code you have given.
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,700
Members
448,293
Latest member
jin kazuya

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