Excel VBA - Save As suggested filename and filepath from a cell value - excel

I have a macro in an Excel Workbook, that is connected to a button that says Export
When I click the button, it triggers the Export XML dialog and I have to manually search for a folder to export it into and enter the filename.
Since the folders in my Documents are named exactly the same as the value of the Cell A24, i would like it to direct itself into the correct folder and suggest me a filename based on the value of the Cell A24 with some extra text behind it.
So far i have this in the VBA:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim POFileName As String
Dim FOFileName As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24")
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22")
POFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath & FOFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath & POFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
This gives me the right filename suggestion, but it doesn't direct me to the folder and goes to Desktop.
Any help would be appriciated!
EDIT:
I tried merging the Strings together a bit more and came up with this:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22") & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
The problem is, that VBA thinks that in:
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
the first Range("A24") belongs to the filename part and doesn't continue on with the filepath. So if the value in A24 was "test", then this suggests saving the xml to Desktop with the filename testttest_report 11 2020

Related

Saving a Excel sheet

So i have found 2 macros which i want to use to save and create a back up files for the said file.
The Macro which i want to primarily use is this one:
Sub DateFolderSave()
Dim strGenericFilePath As String: strGenericFilePath = "D:\"
Dim strYear As String: strYear = Year(Date) & "\"
Dim strMonth As String: strMonth = MonthName(Month(Date)) & "\"
Dim strDay As String: strDay = Day(Date) & "\"
Dim strFileName As String: strFileName = "_Dispatch Process_"
Application.DisplayAlerts = False
' Check for year folder and create if needed
If Len(Dir(strGenericFilePath & strYear, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear
End If
' Check for month folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth
End If
' Check for date folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth & strDay, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth & strDay
End If
' Save File
ActiveWorkbook.SaveAs FileName:= _
strGenericFilePath & strYear & strMonth & strDay & strFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
' Popup Message
MsgBox "File Saved As: " & vbNewLine & strGenericFilePath & strYear & strMonth & strDay & strFileName
End Sub
So i found this another Macro which make continuous back up of the files and has a custom format to a file name
Sub Save_Backup(ByVal Backup_Folder_Path As String)
Dim fso As Object
Dim ExtensionName As String, FileName As String
Dim wbSource As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set wbSource = ThisWorkbook
ExtensionName = fso.GetExtensionName(wbSource.Name)
FileName = Replace(wbSource.Name, "." & ExtensionName, "")
fso.CopyFile ThisWorkbook.FullName, _
fso.BuildPath(Backup_Folder_Path, FileName & " (" & Format(Now(), "dd-mmm-yy hh.mm AM/PM") & ")." & ExtensionName)
Set fso = Nothing
Set wbSource = Nothing
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Call Save_Backup("C:\Users\admin\Downloads\Back Up\New Backup")
End Sub
So i want to create back up like the first macro(i.e. Folder inside a folders for the specific date) but want to have a continuous stream of files for back up(i.e. Want the date folder to create new save file each time i save the Document)
Is there a way to combine both these macros?

Delimiter in VBA,Macros

Need to split the 3rd row and have it in the below xml format.
My Excel data:
ID
EMail
UserGroupID
Aravind
Aravind#gmail.com
Sports(12-34)
Aravind2
Aravind2#gmail.com
Sports(3-24-5),Health(5-675-85), Education(57-85-96)
My XML data:
<?xml version="1.0" encoding="utf-8"?>
<Core-data ContextID="Context1" WorkspaceID="Main">
<UserList>
<User ID="Aravind" ForceAuthentication="false" Password="1234" EMail="Aravind#gmail.com">
<Name>Aravind</Name>
<UserGroupLink UserGroupID="12-34"/>
</User>
<User ID="Aravind2" ForceAuthentication="false" Password="1234" EMail="Aravind#gmail.com">
<Name>Aravind2</Name>
<UserGroupLink UserGroupID="3-24-5"/>
<UserGroupLink UserGroupID="5-675-85"/>
<UserGroupLink UserGroupID="57-85-96"/>
</User>
</UserList>
</Core-data>
The code Im using:(Need change in delimiting the 3 rd row & location only)
Sub Generate_xml()
Const FOLDER = "C:\Temp\"
Const XLS_FILE = "UserDataEntry.xlsm"
Const XML_FILE = "User XML.xml"
Const XML = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf & _
"<Core-data ContextID=""Context1"" WorkspaceID=""Main"">" & vbCrLf & _
" <UserList>" & vbCrLf
Dim wb As Workbook, ws As Worksheet, ar, s As String
Dim iLastRow As Long, r As Long, n As Integer
' open source workbook
Set wb = Workbooks.Open(FOLDER & XLS_FILE, 1, 1)
Set ws = wb.Sheets("Sheet1")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
' create XML document
'<User ID="Aravind" ForceAuthentication="false" Password="1234" EMail="Aravind#gmail.com.com">
' <Name>Aravind</Name>
' <UserGroupLink UserGroupID="Sports"/>
'</User>
s = XML
For r = 2 To iLastRow
s = s & " <User ID=""" & ws.Cells(r, 1) & """" & _
" ForceAuthentication=""false"" Password=""1234""" & _
" EMail=""" & ws.Cells(r, 2) & """>" & vbCrLf
s = s & " <Name>" & ws.Cells(r, 1) & "</Name>" & vbCrLf
ar = Split(ws.Cells(r, 3), ",")
For n = LBound(ar) To UBound(ar)
s = s & " <UserGroupLink UserGroupID=""" & Trim(ar(n)) & """/>" & vbCrLf
Next
s = s & " </User>" & vbCrLf
Next
s = s & " </UserList>" & vbCrLf & "</Core-data>"
' save
Dim fso, ts
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.createtextfile(FOLDER & XML_FILE)
ts.write s
ts.Close
MsgBox "Xml created to " & FOLDER & XML_FILE
End Sub
Is there is any way to run this VBA code in any location and the XML generated to be in same location.
Kindly share your inputs & thanks in advance.
Try something like this:
Sub Generate_xml()
Const FOLDER = "C:\Temp\"
Const XLS_FILE = "UserDataEntry.xlsm"
Const XML_FILE = "User XML.xml"
Const XML = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf & _
"<Core-data ContextID=""Context1"" WorkspaceID=""Main"">" & vbCrLf & _
" <UserList>" & vbCrLf
Dim wb As Workbook, ws As Worksheet, s As String, savePath As String
Dim r As Long, e
' open source workbook
Set wb = Workbooks.Open(FOLDER & XLS_FILE, 1, 1)
Set ws = wb.Sheets("Sheet1")
' create XML document
s = XML
For r = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
s = s & " <User ID=""" & ws.Cells(r, 1) & """" & _
" ForceAuthentication=""false"" Password=""1234""" & _
" EMail=""" & ws.Cells(r, 2) & """>" & vbCrLf
s = s & " <Name>" & ws.Cells(r, 1) & "</Name>" & vbCrLf
For Each e In TextInParentheses(ws.Cells(r, 3).Value)
s = s & " <UserGroupLink UserGroupID=""" & Trim(e) & """/>" & vbCrLf
Next e
s = s & " </User>" & vbCrLf
Next
s = s & " </UserList>" & vbCrLf & "</Core-data>"
'wb.Close false 'close source workbook
' save to same path as running code
savePath = ThisWorkbook.Path & "\" & XML_FILE
PutContent savePath, s
MsgBox "Xml created at '" & savePath & "'", vbInformation
End Sub
'all texts enclosed in parentheses as a collection
Function TextInParentheses(txt As String)
Dim re As Object
Dim allMatches, m, col As New Collection
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "\(([^\)]+)\)"
re.ignorecase = True
re.Global = True
Set allMatches = re.Execute(txt)
For Each m In allMatches
col.Add Trim(m.submatches(0))
Next m
Set TextInParentheses = col
End Function
'Save text `content` to a text file at `f`
Sub PutContent(f As String, content As String)
CreateObject("scripting.filesystemobject"). _
opentextfile(f, 2, True).write content
End Sub

Excel Data to XML

Need to convert excel data into XML format.
'vba code to convert excel to xml
Sub vba_code_to_convert_excel_to_xml()
Set wb = Workbooks.Open("C:\temp\testwb.xlsx")
wb.SaveAs fileName:="C:\temp\testX.xml", FileFormat:= _
xlXMLSpreadsheet, ReadOnlyRecommended:=False, CreateBackup:=False
Kindly let me how to do this in VBA or provide a link where I can refer. Thanks in Advance.
For a simple case one way would be to build the xml line by line
Sub vba_code_to_convert_excel_to_xml2()
Const FOLDER = "C:\temp\"
Const XLS_FILE = "testwb.xlsx"
Const XML_FILE = "testX.xml"
Const XML = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf & _
"<Core-Information ContextID=""Context1"" WorkspaceID=""Main"">" & vbCrLf & _
" <UserList>" & vbCrLf
Dim wb As Workbook, ws As Worksheet, ar, s As String
Dim iLastRow As Long, r As Long, n As Integer
' open source workbook
Set wb = Workbooks.Open(FOLDER & XLS_FILE, 1, 1)
Set ws = wb.Sheets("Sheet1")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
' create XML document
'<User ID="Aravind" ForceAuthentication="false" Password="1234" EMail="Aravind#gmail.com">
' <Name>Aravind</Name>
' <UserGroupLink UserGroupID="Sports"/>
'</User>
s = XML
For r = 2 To iLastRow
s = s & " <User ID=""" & ws.Cells(r, 1) & """" & _
" ForceAuthentication=""false"" Password=""" & ws.Cells(r, 2) & """" & _
" EMail=""" & ws.Cells(r, 3) & """>" & vbCrLf
s = s & " <Name>" & ws.Cells(r, 1) & "</Name>" & vbCrLf
ar = Split(ws.Cells(r, 4), ",")
For n = LBound(ar) To UBound(ar)
s = s & " <UserGroupLink UserGroupID=""" & Trim(ar(n)) & """/>" & vbCrLf
Next
s = s & " </User>" & vbCrLf
Next
s = s & " </UserList>" & vbCrLf & "</Core-Information>"
' save
Dim fso, ts
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.createtextfile(FOLDER & XML_FILE)
ts.write s
ts.Close
MsgBox "Xml created to " & FOLDER & XML_FILE
End Sub

Access VBA opening Temp.xls instead of set filepath

I have code in Access that opens an excel template then saves it based on filepath. The template is then closed and I have put code in that will open the recently saved file. However, the file that opens is the temp.xlsm.
I have spent hours trying to figure out where I am going wrong but no luck, unless I am asking google the wrong question.
This is the part of my code that opens the template, saves it as, and then closes the template to reopen the saved file. Debugs are giving the correct file paths so I can't understand why the temp file keeps opening.
Dim objXLApp As Object
Dim objXLBook As Object
Dim objXLBookNew As Object
Dim FilePath As String
Dim strPath As String
Set objXLApp = CreateObject("Excel.Application")
FilePath = Forms!fm_MainMenu!fm_FilePath_Template.Form!File_Path & "\" & Forms!fm_MainMenu!fm_FilePath_Template.Form!File_Name & "." & Forms!fm_MainMenu!fm_FilePath_Template.Form!File_Type
Debug.Print FilePath
Set objXLBook = objXLApp.Workbooks.Open(FilePath)
objXLApp.Application.Visible = True
Maxletter = DMax("LetterID", "tbl_ReportNo", "[JobNo]= '" & [Forms]![fm_JobHeader]![Job_No] & "'")
Me.ReportNo = DLookup("Letter", "tbl_LetterID", "Letter_ID = " & Maxletter)
objXLBook.ActiveSheet.Range("AI13") = [Forms]![fm_JobHeader]![Job_No] & DLookup("Letter", "tbl_LetterID", "Letter_ID = " & Maxletter)
objXLBook.ActiveSheet.Range("N15") = [Forms]![fm_JobHeader]![Client].Column(1)
objXLBook.ActiveSheet.Range("AF14") = [Forms]![fm_JobHeader]![PONo]
objXLBook.ActiveSheet.Range("S17") = [Forms]![fm_JobHeader]![JobDescription]
objXLBook.ActiveSheet.Range("AT15") = Now()
objXLBook.ActiveSheet.Range("T13") = Me.Discipline.Column(1)
objXLBook.ActiveSheet.Range("Z13") = Me.Type.Column(1)
objXLBook.ActiveSheet.Range("AT16") = Me.RequestWONo
objXLBook.ActiveSheet.Range("S19") = Me.SiteLocation.Column(1)
Dim path_ As String
path_ = Forms!fm_MainMenu!fm_FilePath_Report.Form!File_Path & "\" & [Forms]![fm_JobHeader]![Job_No] & DLookup("Letter", "tbl_LetterID", "Letter_ID = " & Maxletter)
Dim name_ As String
name_ = [Forms]![fm_JobHeader]![Job_No] & DLookup("Letter", "tbl_LetterID", "Letter_ID = " & Maxletter) & ".xlsm"
Debug.Print path_
Debug.Print name_
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(path_) Then .CreateFolder path_
End With
objXLBook.SaveCopyAs FileName:=path_ & "\" & name_
objXLBook.Close False
Set objXLBook = Nothing
Dim path2_ As String
path2_ = Forms!fm_MainMenu!fm_FilePath_Report.Form!File_Path & "\" & [Forms]![fm_JobHeader]![Job_No] & DLookup("Letter", "tbl_LetterID", "Letter_ID = " & Maxletter)
Dim name2_ As String
name2_ = [Forms]![fm_JobHeader]![Job_No] & DLookup("Letter", "tbl_LetterID", "Letter_ID = " & Maxletter) & ".xlsm"
Set objXLApp = CreateObject("Excel.Application")
Set objXLBookNew = objXLApp.Workbooks.Open(path2_ & "\" & name2_)
Debug.Print path2_
Debug.Print name2_
objXLApp.Application.Visible = True
DoCmd.Hourglass False ' turn off hourglass
Set objXLBookNew = Nothing
Set db = Nothing
Set rec = Nothing
Debug of file_ C:\Users\OneDrive\Current Working Docs\Reports Database\ABC123AY
Debug of path_ ABC123AY.xlsm
Debug of file2_ C:\Users\OneDrive\Current Working Docs\Reports Database\ABC123AY
Debug of path2_ ABC123AY.xlsm
But file that is being opened is
C:\Temp\Temp.xlsm
Maybe I have been looking at this too long and the obvious is staring me in the face but I am gaining frustration. Any help very much appreciated.

Saving an excel file based on prepopulated cells

I made a Commandbutton that will allow the user to save the file based on the values within the excel cells in which the cells are pre-populated to begin with. Also how do you implement this fuction GetSaveAsFilename so the user can choose a save destination but not change the title. But I am getting an error executing this code.
Private Sub CommandButton2_Click()
Sub SaveMyWorkbook()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "C:\Users\"
strPath = strFolderPath & _
DoNotPrint - Setup.Range("C7").Value & " " & _
DoNotPrint - Setup.Range("C8").Value & " " & _
DoNotPrint - Setup.Range("C45").Value & " " & _
DoNotPrint - Setup.Range("C9").Value & ".xlsm"
End Sub
Best guess:
With Thisworkbook.sheets("DoNotPrint - Setup")
strPath = strFolderPath & .Range("C7").Value & " " & _
.Range("C8").Value & " " & _
.Range("C45").Value & " " & _
.Range("C9").Value & ".xlsm"
End with
Selecting a folder to save to:
VBA EXCEL To Prompt User Response to Select Folder and Return the Path as String Variable
To allow the user to choose the folder I use this:
Private Sub CommandButton2_Click()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "C:\Users\"
strPath = strFolderPath & _
DoNotPrint - Setup.Range("C7").Value & " " & _
DoNotPrint - Setup.Range("C8").Value & " " & _
DoNotPrint - Setup.Range("C45").Value & " " & _
DoNotPrint - Setup.Range("C9").Value & ".xlsm"
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.InitialFileName = strPath
.FilterIndex = 2
.Title = Place Title Here if you want
If .Show = -1 Then .Execute
End With
End Sub
Based on Tim's and Zack's Answer, this worked
Private Sub CommandButton2_Click()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "C:\Users\"
With ThisWorkbook.Sheets("DoNotPrint - Setup")
strPath = strFolderPath & .Range("C7").Value & " " & _
.Range("C8").Value & " " & _
.Range("C45").Value & " " & _
.Range("C9").Value & ".xlsm"
End With
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.InitialFileName = strPath
.FilterIndex = 2
If .Show = -1 Then .Execute
End With
End Sub

Resources