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>

 

[DragonWood]

Ok, within that same code, add this just before the End Sub. That way it will happen in the new file only after it is created.

     With Sheets("Sheet1")
        .Range("D1:AM100").Select
        .Range("D1:AM100").Copy
        .Range("D1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
     End With

Of course, change "Sheet1" to whatever your worksheet is named. The rest should work as is.

Because the other code creates a copy of the original file and places it in the new location, all your formatting should remain intact.

 

[Ingolf]

Thank you Dragon for quick response. I try your solution but in the file this code copy all not only range D1:AM100. Thank you anyway.

 

[DragonWood]

Maybe I didn't understand what you wanted to do.

If you use the code that Warship provided. It saves a copy of your entire workbook to a new location.

That means that the cells you want to copy are already there.

The code I just gave you selects all the cells between D1 and AM100, then copies them and repastes them in the same location but only pastes the values.

Is that not what you wanted?

 

[Ingolf]

Dragon,

No, I don't want to copy range D1:AM100 in the same file.
I want to copy this range (D1:AM100) from file I run the code from Warship
and pasted (something like copy - paste special) in file new created.
C:\TEMP\name from cell B2\name from cell B8\name from cell B4\file.xlsx with name from cell B4. In file marked red I need to pasted - starting A1 - the range D1:AM100. If is possible.
Thank you.

 

[DragonWood]

Just to make sure I understand.

You want to make a new file in a new location based on the values of certain cells. Which is what the code that Warship provided does.

However, you want the new file to only contain the values and formatting from cells D1 through AM100. You do NOT want the entire workbook copied.

Correct?

 

[Ingolf]

Dragon,

1. The code from Warship is in answer nr 4, replayed to you
2. Correct. I want the new file to only contain the values and formatting from cells D1 through AM100 NOT the entire workbook copied

Thanks

 

[DragonWood]

Ok, after a little research and a lot of trial and error I have a working code for you.

Place this in a module and make the necessary changes to make it save where you want it to.

Sub SaveToFolder()
'Saves the file to a set folder path based on cell values on Sheet1
'Removes columns A through C and all formulas, leaving just the data and formatting
    Dim fileSaveName As String
    Dim jobSaveName As String
    Dim locationSaveName As String
    Dim compSaveName 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
    Dim compInput As String
    Dim jobInput As String
    Dim locationInput As String
'Establish the file names, providing an input box if needed
 
    With Sheets("Sheet1")
    If .Range("B2").Value = "" Then
        .Range("B2").Select
        compInput = InputBox("Please enter the Company Name.", "Company Name")
        ActiveCell.FormulaR1C1 = compInput
    End If
    If .Range("B4").Value = "" Then
        .Range("B4").Select
        jobInput = InputBox("Please fill in the Job Name.", "Job Name")
        ActiveCell.FormulaR1C1 = jobInput
    End If
    If .Range("B8").Value = "" Then
        .Range("B8").Select
        locationInput = InputBox("Please fill in the Location Name.", "Location Name")
        ActiveCell.FormulaR1C1 = locationInput
    End If
 
        fileSaveName = CleanFileName(.Range("B4").Value) & ".xlsm"
        jobSaveName = CleanFileName(.Range("B4").Value) & "\"
        locationSaveName = CleanFileName(.Range("B8").Value) & "\"
        compSaveName = CleanFileName(.Range("B2").Value) & "\"
    End With
'Declare the file path
 
    fileRootPath = "C:\Projects\"
 
    fileSavePath = fileRootPath & compSaveName & locationSaveName & 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
'Save a copy of the workbook in the new location
 
    ActiveWorkbook.SaveAs Filename:=fileSavePath & fileSaveName
'Remove columns A through C
 
    With Sheets("Sheet1")
        Columns("A:C").Select
        Selection.Delete Shift:=xlToLeft
'Remove the formulas by copying and special pasting
        Range("A1:AJ100").Select
        Range("A1:AJ100").Copy
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Range("A1").Select
    End With
'Save the changes made to the new workbook
 
    ActiveWorkbook.Save
 
End Sub
 
Function CleanFileName(sFileName As String, Optional ReplaceInvalidwith As String = "") As String
    'Removes invalid filename characters
 
    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

I hope this is what you were looking for.

 

[Ingolf]

Dragon,

Thank you so much. It is all I needed. Million tanks.