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.
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
54,838
Office Version
  1. 365
Platform
  1. Windows
What is the value in E8 of the file you are testing?
 

Some videos you may like

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
its numbers... example: 712200
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
54,838
Office Version
  1. 365
Platform
  1. Windows
OK, I think I see the problem. I was thinking that the entire file path was in cell E8, and not just the last folder.
A few small tweaks should do it:
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
    If Right(fldr, 1) <> "\" Then fldr = fldr & "\"
        
'   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 = fldr & 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
    Kill fldr & "*.xls*"
        
    Application.ScreenUpdating = True
    
    MsgBox "Macro Complete!"
           
End Sub
 

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Joe , its working but its not creating any new folder with ref to cell E8.. its saving in the same source file path!!!
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
54,838
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Joe , its working but its not creating any new folder with ref to cell E8.. its saving in the same source file path!!!
Isn't that the path that the file started in? So really it didn't do anything at all, right?
Can you verify that you have permission to create new folders in the directory?

I would recommend stepping into your code and go through one line at a time, using F8 key, and watch what is happening.
That may shed some light as to what is going on.
 

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
yes.. I debugged it.. and found it already!! but I put it in words last time. it opens the wb and then directly jumps to save as option.. I believe the problem is with the below code If function...

VBA Code:
'           Get new folder name from cell E8
            newFldr = fldr & 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
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
54,838
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I've added two message boxes to the code. Please tell me exactly what they return:
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
    If Right(fldr, 1) <> "\" Then fldr = fldr & "\"
    MsgBox "fldr is: " & fldr
        
'   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 = fldr & Range("E8").Value
            If Right(newFldr, 1) <> "\" Then newFldr = newFldr & "\"
            MsgBox "newFldr is: " & 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
    Kill fldr & "*.xls*"
        
    Application.ScreenUpdating = True
    
    MsgBox "Macro Complete!"
           
End Sub
 

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi Roy, Im attaching the screen shots here fyr. for more clarity!!! 1-2-3 is the sequence.. as I told its not creating a seperate folder named with cell value of E8 while its doing "Save As" in the same folder.
 

Attachments

  • 1.JPG
    1.JPG
    146.7 KB · Views: 3
  • 2.JPG
    2.JPG
    166.2 KB · Views: 3
  • 3.jpg
    3.jpg
    241.4 KB · Views: 3

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
54,838
Office Version
  1. 365
Platform
  1. Windows
Hi Roy, Im attaching the screen shots here fyr. for more clarity!!!
No really sure who Roy is.:unsure:

I think I can guess what is happening. It is probably one of two things:
1. Cell E8 is not populated
- or -
2. When the workbook opens, it has multiple sheets, and it is not on the sheet that has E8 populated

If it is number 2, can you explain the layout of these files? How many sheets? Is the populated E8 always on the first sheet, or a sheet with a particular name?
 

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi Sorry Joe... I was speaking to my colleague and typed his name..:(coming back to this, you are right!! I have two sheets of which I need to check cell E8, from the sheet name "Order Template"..
 

Watch MrExcel Video

Forum statistics

Threads
1,112,998
Messages
5,543,194
Members
410,585
Latest member
MaintenanceReportGuy
Top