Save As macro with path and filename from cells Excel

[gelu]

Hello everyone,

I wrote a save as macro:

' Save_As_Names_In_Cells Macro
'
ChDir "C:\MrExcel"
ActiveWorkbook.SaveAs Filename:="C:\MrExcel\Macros\Test.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub

I do not know how to tell it to pick:
- the root from range A1= "C:\ " or else
- "MrExcel" from A2 (folder name)
- "Macros", from A3 (subfolder)
- "Test.xlsm" from A4 (filename and type)

... so that users can change root\directory\filename by editing cells A1:A4 of Sheet1

Also, the saved as file should remain open.

Help would be much appreciated.

Kind regards,

GT

 

[HaHoBe]

Hi gelu,

data should be inserted without quotes into the cells:

Sub s13a()
' Save_As_Names_In_Cells Macro
'

Dim strPathFileName As String
Dim lngFileFormat As Long
'ChDir "C:\MrExcel"

With ActiveSheet
  strPathFileName = IIf(Right(.Range("A1").Value, 1) = "\", .Range("A1").Value, .Range("A1").Value & "\")
  strPathFileName = strPathFileName & IIf(Right(.Range("A2").Value, 1) = "\", .Range("A2").Value, .Range("A2").Value & "\")
  If Dir(Left(strPathFileName, Len(strPathFileName) - 1), vbDirectory) = vbNullString Then Exit Sub
  strPathFileName = strPathFileName & IIf(Right(.Range("A3").Value, 1) = "\", .Range("A3").Value, .Range("A3").Value & "\")
  strPathFileName = strPathFileName & .Range("A4").Value
  If Len(Dir(strPathFileName)) > 0 Then
    MsgBox "File already exists, change file name", vbInformation, "File exists"
    Exit Sub
  End If
  Select Case UCase(Mid(.Range("A4").Value, InStrRev(.Range("A4").Value, ".") + 1))
    Case "XLSX"
      lngFileFormat = 51
    Case "XLSM"
      lngFileFormat = 52
    Case "XLS"
      lngFileFormat = 56
    Case Else
      MsgBox "Suffix not supported. Please check and alter to xlsx, xlsm or xls", , "Abort macro"
      Exit Sub
  End Select
End With
ActiveWorkbook.SaveAs Filename:=strPathFileName, FileFormat:=lngFileFormat, CreateBackup:=False

End Sub

Holger

 

[gelu]

Hi Holger,

It works beautifully.

Thank you for your help.

Gelu

 

[HaHoBe]

Hi gelu,

a slightly modified version (lots of more lines...). Sheet looks like this

Test.xlsm
	A	B
1	Laufwerk/Drive	C:\
2	Hauptordner/Folder	MrExcel
3	Unterordner/SubFolder	Macros
4	Dateiname mit Endung/Filename with extension	Test.xlsm
Save active Workbook

Code used:

Sub s13b()
' Save_As_Names_In_Cells Macro
'

Dim strPathFileName     As String
Dim lngFileFormat       As Long

With ActiveSheet
  strPathFileName = fncCheckDriveFolder(.Range("B1").Value)
  strPathFileName = fncCheckDriveFolder(strPathFileName & .Range("B2").Value)
  strPathFileName = fncCheckDriveFolder(strPathFileName & .Range("B3").Value)
  strPathFileName = strPathFileName & .Range("B4").Value
 
  If Len(Dir(strPathFileName)) > 0 Then
    MsgBox "File already exists, change file name", vbInformation, "File exists"
    Exit Sub
  End If
 
  Select Case UCase(Mid(.Range("B4").Value, InStr(.Range("B4").Value, ".") + 1))
    Case "XLSX"
      lngFileFormat = 51
    Case "XLSM"
      lngFileFormat = 52
    Case "XLS"
      lngFileFormat = 56
    Case Else
      MsgBox "Suffix not supported. Please check and alter to xlsx, xlsm or xls", , "Abort macro"
      Exit Sub
  End Select
End With

ActiveWorkbook.SaveAs Filename:=strPathFileName, FileFormat:=lngFileFormat, CreateBackup:=False

End Sub

Public Function fncCheckDriveFolder(strPath As String) As String
'will check last sign to be a backslash as well as that the path does exist
'Parameter: strPath, Drive and path to the folder
'Return:    available path to the destination folder
  Dim strWork     As String
 
  strWork = Trim(strPath)
  If Right(strWork, 1) <> "\" Then strWork = strWork & "\"
  strWork = CleanFilename(strWork)
  If InStr(1, strWork, "\\") > 0 Then
    MsgBox "PLease check for opath" & vbCrLf & strWork, vbInformation, "Check path because of '\\'"
    End
  End If
  If Dir(Left(strWork, Len(strWork) - 1), vbDirectory) = vbNullString Then
    MsgBox "The path:" & vbCrLf & strWork & vbCrLf & "is not available. Please check!", vbExclamation, "Did not find path"
    End
  End If
  fncCheckDriveFolder = strWork
End Function

Public Function CleanFilename(ByVal strFilename As String, _
        Optional ByVal strChar As String = "") As String
'will strip the path to the folder from illegal characters except \\
'Parameters: strFilename, drive and folder(s) to the path
'            strChar, replacement for illegal characters, we take "" or vbNullstring
'Return:     valid string for drive and path according to recstrictions
  Dim oRegExp     As Object
 
  Set oRegExp = CreateObject("VBScript.RegExp")
  With oRegExp
    .IgnoreCase = True
    .Global = True
    .MultiLine = True
    .Pattern = "[/?*^""<>|]"
    CleanFilename = .Replace(strFilename, strChar)
  End With
  Set oRegExp = Nothing
End Function

As I had started working on this before you answered...

Glad the ocde worked like expected.
Holger

 

[gelu]

A spreadsheet wizard lent me a hand ....
Great craft! I am just starting with VBA so this is like rocket science to me.

Best wihes,

Gelu

 

[HaHoBe]

Hi Gelu,

the more you will learn about VBA the more you will realize how limited my knowledge is. Thanks for the feedback.

I tried to implement two very different things in one Function which are contradictory to each other: the drive needs a letter, a colon and a backslash whereas in a foldername no colon is allowed. So I adjusted the code, calling CleanFilename from the sub as well as fncCheckDriveFolder. Please find the altered code below (I must admit I didn't use RegEx but Replace instead in my former codings):

Sub s14()
' Save_As_Names_In_Cells Macro
'

Dim strPathFileName     As String
Dim lngFileFormat       As Long

With ActiveSheet
  strPathFileName = fncCheckDriveFolder(.Range("B1").Value)
  strPathFileName = fncCheckDriveFolder(strPathFileName & CleanFilename(.Range("B2").Value))
  strPathFileName = fncCheckDriveFolder(strPathFileName & CleanFilename(.Range("B3").Value))
  strPathFileName = strPathFileName & CleanFilename(.Range("B4").Value)
  
  If Len(Dir(strPathFileName)) > 0 Then
    MsgBox "File already exists, change file name", vbInformation, "File exists"
    Exit Sub
  End If
  
  Select Case UCase(Mid(.Range("B4").Value, InStr(.Range("B4").Value, ".") + 1))
    Case "XLSX"
      lngFileFormat = 51
    Case "XLSM"
      lngFileFormat = 52
    Case "XLS"
      lngFileFormat = 56
    Case Else
      MsgBox "Suffix not supported. Please check and alter to xlsx, xlsm or xls", , "Abort macro"
      Exit Sub
  End Select
End With

ActiveWorkbook.SaveAs Filename:=strPathFileName, FileFormat:=lngFileFormat, CreateBackup:=False

End Sub

Public Function fncCheckDriveFolder(strPath As String) As String
'will check last sign to be a backslash as well as that the path does exist
'Parameter: strPath, Drive and path to the folder
'Return:    available path to the destination folder
  Dim strWork     As String
  
  strWork = Trim(strPath)
  If Right(strWork, 1) <> "\" Then strWork = strWork & "\"
  If InStr(1, strWork, "\\") > 0 Then
    MsgBox "Please check for path" & vbCrLf & strWork, vbInformation, "Check path because of '\\'"
    End
  End If
  If Dir(Left(strWork, Len(strWork) - 1), vbDirectory) = vbNullString Then
    MsgBox "The path:" & vbCrLf & strWork & vbCrLf & "is not available. Please check!", vbExclamation, "Did not find path"
    End
  End If
  fncCheckDriveFolder = strWork
End Function

Public Function CleanFilename(ByVal strFilename As String, _
        Optional ByVal strChar As String = "") As String
'will strip the foldername of illegal characters
'Parameters: strFilename, foldername
'            strChar, replacement for illegal characters, we take "" or vbNullstring
'Return:     valid string for foldername
  Dim oRegExp     As Object
  
  Set oRegExp = CreateObject("VBScript.RegExp")
  With oRegExp
    .IgnoreCase = True
    .Global = True
    .MultiLine = True
    .Pattern = "[/?*:^""<>|]"
    CleanFilename = .Replace(strFilename, strChar)
  End With
  Set oRegExp = Nothing
End Function

Code may be modified to show a date time stamp for the filename or a formatted number to save each file and distinguish them from each other (I prefer the date time stamp like yymmdd_hhmmss to keep them shown in chronological order in the Explorer).

HTH,
Holger

 

[gelu]

Hi Holger,

I never used VBA before (except simple macros). But now a develop a simple application which needs some automation. I can see how handy it is to use VBA.
By date stamp you mean to save the file so that it incudes the date in its name?

Gelu

 

[HaHoBe]

Hi Gelu,

instead of Test.xlsm it would be called like Test_221004_204917.xlsm replacing the codeline

  strPathFileName = strPathFileName & CleanFilename(.Range("B4").Value)

by these lines

  Dim varSplit As Variant
  '/// Split is available from Excel2000 on and splits data with a given divisor, here a point between name and extension
  varSplit = Split(CleanFilename(Range("B4").Value), ".")
  strPathFileName = strPathFileName & varSplit(0) & Format(Now(), "_yymmdd_hhmmss") & "." & varSplit(1)

Have fun
Holger

 

[gelu]

Thank you!
This is Great!

 

[smozgur]

It works beautifully.

The marked solution post has been changed accordingly.

@gelu: In your future questions please mark the post as the solution that answered your question as it will help future readers. No further action is required for this thread.