Saving a Workbook based on Cell Values

[DragonWood]

Ok, I’m a little lost.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
I’m trying to save my file to a location based on the values of a few cells. I have the following code so far:<o></o>

Sub SaveToFolder()
'Saves the file to a set folder path based on the cell values on the General Information page<o:p></o:p>
Dim fileSaveName As String
Dim jobSaveName As String
Dim foldSaveName As String
Dim dirSaveName As String<o:p></o:p>
fileSaveName = Sheets("General Information").Range("B4").Value
jobSaveName = Sheets("General Information").Range("B4").Value
foldSaveName = Sheets("General Information").Range("B8").Value
dirSaveName = Sheets("General Information").Range("B2").Value<o:p></o:p>
MkDir "C:\Test" & "\" & "Files" & "\" & dirSaveName & "\" & foldSaveName & "\" & jobSaveName<o:p></o:p>
ActiveWorkbook.SaveAs Filename:="C:\Neset\Wells\" & dirSaveName & "\" & foldSaveName & "\" & jobSaveName & “\” & fileSaveName & ".xlsm"<o:p></o:p>
End Sub<o:p></o:p>

<o></o>
<o></o>
I keep getting an error saying the path is not found and the MkDir line is highlighted.<o></o>
<o></o>
I can’t see where I did something wrong.<o></o>

 

[Warship]

Difficult to say with seeing your Range Values.

To see what MkDir is seeing try Replacing MkDir with MsgBox.
When you run the code, check the path that comes up is valid

BTW - fileSaveName and jodSaveName are set to the same range value, just in case you didn't know.

 

[DragonWood]

The Range Values would be whatever the job details are.

The break down is:

Cell B2 is the name of the Company we're working with.

Cell B8 is the name of the Location we're at.

Cell B4 is the name of this particular job.

On occasion, Cell B2 and Cell B8 will be the same this time as last time.

Cell B4 will always be different. I want a folder (to put all files based on that job into) plus the workbook should be named the same as the job.

What I want is to make a directory based on the cells.

In order, they should go B2\B8\B4\B4.xlsm

I did the MsgBox and it showed me the correct directories, but didn't show the filename.

 

[Warship]

I meant that without seeing the actual values I couldn't look for invalid characters.
I have included an invalid char stripper here.

MkDir will only make ONE dir at a time.
So in order to MkDir "C:\Test\Files\"
You would first have to MkDir "C:\Test\"

Try:

Sub SaveToFolder()
'Saves the file to a set folder path based on the cell values on the General Information page
    Dim fileSaveName As String
    Dim jobSaveName As String
    Dim foldSaveName As String
    Dim dirSaveName As String
    
    Dim fileRootPath As String
    Dim fileSavePath As String
    Dim dirDepth As Long
    Dim nextDir As Long
    Dim tempDir As String
    Dim x As Long
    
    With Sheets("General Information")
        fileSaveName = CleanFileName(.Range("B4").Value) & ".xlsm"
        jobSaveName = CleanFileName(.Range("B4").Value) & "\"
        foldSaveName = CleanFileName(.Range("B8").Value) & "\"
        dirSaveName = CleanFileName(.Range("B2").Value) & "\"
    End With
    
    fileRootPath = "C:\Test\Files\" '"C:\Neset\Wells\" change as needed
    
    fileSavePath = fileRootPath & dirSaveName & foldSaveName & jobSaveName
    
    If Dir(fileSavePath, vbDirectory) = "" Then
        dirDepth = Len(fileSavePath) - Len(Replace(fileSavePath, "\", ""))
        nextDir = InStr(fileSavePath, "\")
        For x = 1 To dirDepth - 1
            nextDir = InStr(nextDir + 1, fileSavePath, "\")
            tempDir = Left(fileSavePath, nextDir)
            If Dir(tempDir, vbDirectory) = "" Then MkDir tempDir
        Next x
    End If
    
    ActiveWorkbook.SaveAs FileName:=fileSavePath & fileSaveName
    
End Sub

Function CleanFileName(sFileName As String, Optional ReplaceInvalidWith As String = "") As String
    'remove invalid filename chars
    Const InvalidChars As String = "%~:\/?*<>|"""
    Dim ThisChar As Long
    CleanFileName = sFileName
    For ThisChar = 1 To Len(InvalidChars)
        CleanFileName = Replace(CleanFileName, Mid(InvalidChars, ThisChar, 1), ReplaceInvalidWith)
    Next
End Function

 

[DragonWood]

Thank you very much. That works almost perfectly.

I just need to add a Message Box that will remind them to fill in the blank fields the code refers to so they don't get a Debug window.

Thanks again.

 

[Ingolf]

Hi, Warship

May I use your code? If yes
Can you tell me how can I change your code to copy and paste special (I need to copy with formating - no need formula inside) the range D1:AM100 from the file I run the VBA code in file.xlsm.

Thank you

 

[Ingolf]

Bump

 

[Ingolf]

Nobody???

 

[DragonWood]

Ingolf,

I think what you're asking for should be in a different thread because what you want isn't really related to this one.

However, I have used this code in a couple of my workbooks. What it does is undo the paste, then does a paste special with values only which protects whatever formatting you have set in your workbook. You can change the part that says "xlPasteValues" to "xlPasteFormat" and it should do what you want.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'This code will undo PASTE and instead do a PASTE SPECIAL VALUES which will
'allow you to retain FORMATS in all of the cells in all of the sheets, but will
'also allow the user to COPY and PASTE data
 
    Dim UndoString As String
    Dim srce As Range
    On Error GoTo err_handler
    UndoString = Application.CommandBars("Standard").Controls("&Undo").List(1)
 
    If VBA.Left(UndoString, 5) <> "Paste" And UndoString <> "Auto Fill" Then
 
        Exit Sub
 
    End If
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Undo
 
 
    If UndoString = "Auto Fill" Then
 
        Set srce = Selection
 
        srce.Copy
 
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
        Application.SendKeys "{ESC}"
        Union(Target, srce).Select
 
    Else
 
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
    End If
 
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub
err_handler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

The best way to make sure you catch all the changes is to paste this into a text file first. Then press Ctrl+H on your keyboard and it will ask you what you want to change.

 

[Ingolf]

Dragon,

I use the last code from Warship to create folder in folder in folder and file inside the last folder (C:\TEMP\name from cell B2\name from cell B8\name from cell B4\file.xlsx with name from cell B4. Now I need to copy range D1:AM100 and paste special ( need only value and format of cell no need the formula inside cell) in file new created.
Hope I explain well.