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]

What is the value in E8 of the file you are testing?

 

[wells]

its numbers... example: 712200

 

[Joe4]

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:

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]

Joe , its working but its not creating any new folder with ref to cell E8.. its saving in the same source file path!!!

 

[Joe4]

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]

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...

'           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]

I've added two message boxes to the code. Please tell me exactly what they return:

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]

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.

 

[Joe4]

Hi Roy, Im attaching the screen shots here fyr. for more clarity!!!

No really sure who Roy is.

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]

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"..