Need Help Saving To folder

[will2learn]

I'm using some code I found on this site to select the main folder and save a file to it. I now need to amend the code so that it saves the file into a subfolder which is named in a cell.

The cell where the folder name is loacted is in a sheet called LookUpLists cell N9 and this is a lookup formula.

Basically, what I'm trying to do is once I selected the main folder and the macro is going through each record, I want the new file to saved into the folder and into the subfolder named in cell N9. If the folder is not there then I need it to be created and add the file, if it does exist then simply add the file to it.

I have to create over a thousand files into specific folders.

Can anyone help?

sub MyMacro()
Dim sFilter As String
Dim sPath As String

UserFile = PickFolder(strStartDir)
sPath = UserFile & "\" 'ActiveWorkbook.Path & "\"

For Each c In Range("J2:J" & Range("J65536").End(xlUp).Row)
sFilter = c.Value
        
Application.StatusBar = "File for " & c.Value & " is currently being created!"
        
With Sheets("LookupLists").Range("N2")
.Value = c.Value
End With

Set r = Worksheets("LookupLists").Range("O14", Worksheets("LookupLists").Range("O" & Rows.Count).End(xlUp))
Set ws = Sheets(WorksheetFunction.Transpose(r))
ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:=sPath & sFilter & Format(Date, " YYYY MM DD ") & Format(Time, "hh mm") & ".xls"
ActiveWindow.Close
Next c

End Sub


Option Explicit
Function PickFolder(strStartDir As Variant) As String
    Dim SA As Object, F As Object
    Set SA = CreateObject("Shell.application")
    Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
    If (Not F Is Nothing) Then
        PickFolder = F.items.Item.Path
    End If
    Set F = Nothing
    Set SA = Nothing
End Function

 

[AlphaFrog]

    Dim sFilter As String
    Dim sPath  As String

[COLOR="Red"]    sPath = PickFolder(ActiveWorkbook.Path)
    If sPath = "" Then Exit Sub 'User Cancelled

    If IsError(Sheets("LookupLists").Range("N9")) Then MsgBox "No subfolder returned in cell N9.": Exit Sub
    sPath = sPath & "\" & Sheets("LookupLists").Range("N9").Value & "\"
    If Dir(sPath, vbDirectory) = "" Then MkDir sPath[/COLOR]

    For Each c In Range("J2:J" & Range("J65536").End(xlUp).Row)
        sFilter = c.Value

        Application.StatusBar = "File for " & c.Value & " is currently being created!"

        With Sheets("LookupLists").Range("N2")
            .Value = c.Value
        End With

        Set r = Worksheets("LookupLists").Range("O14", Worksheets("LookupLists").Range("O" & Rows.Count).End(xlUp))
        Set ws = Sheets(WorksheetFunction.Transpose(r))
        ws.Select
        ws.Copy
        ActiveWorkbook.SaveAs Filename:=sPath & sFilter & Format(Date, " YYYY MM DD ") & Format(Time, "hh mm") & ".xls"
        ActiveWindow.Close
    Next c

 

[will2learn]

I've used the revised code but am still having a problem. The directory is created but the file is not being saved in to it.

Can anyone help further?

 

[will2learn]

Can anyone assist, as I really need to get this to work.

 

[xenou]

I'm using some code I found on this site to select the main folder and save a file to it. I now need to amend the code so that it saves the file into a subfolder which is named in a cell.

The cell where the folder name is loacted is in a sheet called LookUpLists cell N9 and this is a lookup formula.

Basically, what I'm trying to do is once I selected the main folder and the macro is going through each record, I want the new file to saved into the folder and into the subfolder named in cell N9. If the folder is not there then I need it to be created and add the file, if it does exist then simply add the file to it.

I have to create over a thousand files into specific folders.

Can anyone help?

When you say "save the file" ... what file?
I think it would be better to give sample data in the cells rather than sample code that doesn't work.

Why in the world your job involves copying thousands of files to numerous directories is another question ... Next month you'll be posting again with yet another question ("I have thousands of files in different directories and I need to open each one ...") Without knowing the details, this sounds rather like a bad setup start to finish.

 

[will2learn]

The sample code is taken directly from the file I use so it does work.

What it is currently doing is asking the user to select a folder, the macro then creates individual files for sales people within each region. This is where my dilema is, in that when a folder is selected all the files are saved to it.

What I need to happen is that a main directory is selected and then the c.value changes a lookup value is in cell N9 determines the folder name that is to be used.

So basically, user select a myfolder, the c.value is placed in cell N2, this allows the formula in N9 to lookup and obtain a foldername (such as Bob Smith). The newly created file then is then saved to the folder myfolder/Bob Smith.

If the Bob Smith folder does not exist, then it needs to be created and the file added to it, if the folder does exist then the file needs adding to it.

"Without knowing the details, this sounds rather like a bad setup start to finish." I agree it is a bad setup, hence the reason for trying to improve it!

 

[AlphaFrog]

I've used the revised code but am still having a problem. The directory is created but the file is not being saved in to it.

Can anyone help further?

As a test, add this line in red to the code.

        Set r = Worksheets("LookupLists").Range("O14", Worksheets("LookupLists").Range("O" & Rows.Count).End(xlUp))
        Set ws = Sheets(WorksheetFunction.Transpose(r))
        ws.Select
        ws.Copy
        [COLOR="Red"]If MsgBox(sPath & sFilter & Format(Date, " YYYY MM DD ") & Format(Time, "hh mm") & ".xls", vbOKCancel) = vbCancel Then Exit Sub[/COLOR]
        ActiveWorkbook.SaveAs Filename:=sPath & sFilter & Format(Date, " YYYY MM DD ") & Format(Time, "hh mm") & ".xls"
        ActiveWindow.Close

The message box will display the full path and file name of the workbook it will save. Is there anything wrong with the path and filename?