Excel Data to XML - excel

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

Related

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

Macro that export complete row data based on column name to new excel file getting error in that

Sub ExportCreatePOD()
'File names to be created as " & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now()," MM-DD-YYYY ")"
Dim RngSourceData As Range
Dim RngTarget As Range
Dim RngRange01 As Range
Dim RngRange02 As Range
Dim StrCarrierColumnHeader As String
Dim StrSavePath As String
Dim StrMultipleFileMessage As String
Dim DblCarrierColumnRelativeColumn As Double
Dim DblCounter01 As Double
Dim DblCounter02 As Double
Dim WkbSource As Workbook
Dim WkbTarget As Workbook
'Turning off screen updating.
Application.ScreenUpdating = False
'Setting variables.
Set WkbSource = ActiveWorkbook
Set RngSourceData = WkbSource.Sheets("POD").UsedRange
StrCarrierColumnHeader = "Carrier"
StrSavePath = "C:Path\" '=== Path for POD files Change the Path (where you want to export the POD files)
On Error Resume Next
DblCarrierColumnRelativeColumn = Excel.WorksheetFunction.Match(StrCarrierColumnHeader, RngSourceData.Rows(1), 0)
If Err <> 0 Then
MsgBox "The range " & RngSourceData.Rows(1).Address(False, False) & " contains no column headed " & StrCarrierColumnHeader & ". The subroutine is terminated", vbCritical, "Error"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
Set RngRange01 = RngSourceData.Columns(DblCarrierColumnRelativeColumn).Resize(RngSourceData.Rows.Count - 1).Offset(1, 0)
DblCounter01 = 0
For Each RngTarget In RngRange01.Cells
If Excel.WorksheetFunction.CountIf(RngSourceData.Parent.Range(RngRange01.Cells(1, 1), RngTarget), RngTarget.Value) = 1 Then
'Cheking if any file dedicated to the given carrier already exists for today.
If Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx") = "" Then
'If no such file exists, it is created and saved.
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx"
Else
'Is it does exist, the name is "shifted".
DblCounter02 = 2
Do Until Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx") = ""
DblCounter02 = DblCounter02 + 1
Loop
'Carrier and relative file are copied in StrMultipleFileMessage.
StrMultipleFileMessage = StrMultipleFileMessage & vbCrLf & RngTarget.Value & " in " & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
End If
'Setting RngRange02 to target the range in the new file where RngSourceData will be copied.
Set RngRange02 = WkbTarget.Sheets(1).Range("A1").Resize(RngSourceData.Rows.Count, RngSourceData.Columns.Count)
With RngRange02
'Copying values.
RngSourceData.Copy RngRange02
'Filtering the range to clear the list of unwanted data.
.AutoFilter Field:=DblCarrierColumnRelativeColumn, Criteria1:="<>" & RngTarget.Value
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearContents
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearFormats
'Removing the filter.
.AutoFilter
'Rename Sheet
Sheets("Sheet1").Name = "POD"
'Autofit
Sheets("POD").UsedRange.Columns.AutoFit
'Sorting the range to compact the data.
With .Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange RngRange02
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Saving and closing WkbTarget.
WkbTarget.Close SaveChanges:=True
End If
'Setting DblCounter01.
DblCounter01 = DblCounter01 + 1
Next
'Enabling screen updating.
Application.ScreenUpdating = True
'Reporting if any carrier had its data reported in a "twin" file.
If StrMultipleFileMessage <> "" Then
StrMultipleFileMessage = "The following carriers had already one or more dedicated files at the given path. Their data were saved accordingly to this list:" & vbCrLf & vbCrLf & StrMultipleFileMessage
MsgBox StrMultipleFileMessage, , "Multiple dedicated files"
End If
End Sub
I created a macro that split data based on column name "Carrier" into a new excel file. I have 2 tabs named POL and POD for which I created 2 sets of codes that split data from these tabs based on the column name and created a new excel file, my code for tab POL is working but not for POD. I neither get any error it just executes and create a file but does not paste any data of the POD tab.
Main Excel File which has Macro codes Problem in Tab POD
In this above screen, you can see the POD tab has so much data that macro should create a new file based on column name "Carrier". When I execute the macro it create a new file but there is no data in it meaning the data does not get captured in the newly created POD file. I am pasting the output as follows.
Wrong Output
If you see in the above image no data is captured in the newly created file.
I will paste my complete code below the codes for both the tabs POL and POD. Please guide is there any easy way to cut short the codes that read both POL and POD tabs and create/splits the data into a new excel file based on the column named carrier. However, at present, the problem is with the codes within "
Sub ExportCreatePOD()"
My Complete Codes :-
'--------------------------------Create POL POD XL Sheets---------------------------
Sub ExportCreatePOL()
'File names to be created as " & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now()," MM-DD-YYYY ")"
Dim RngSourceData As Range
Dim RngTarget As Range
Dim RngRange01 As Range
Dim RngRange02 As Range
Dim StrCarrierColumnHeader As String
Dim StrSavePath As String
Dim StrMultipleFileMessage As String
Dim DblCarrierColumnRelativeColumn As Double
Dim DblCounter01 As Double
Dim DblCounter02 As Double
Dim WkbSource As Workbook
Dim WkbTarget As Workbook
Application.ScreenUpdating = False
Set WkbSource = ActiveWorkbook
Set RngSourceData = WkbSource.Sheets("POL").UsedRange
StrCarrierColumnHeader = "Carrier"
StrSavePath = "C:Path\" '===Path where excel files will be created Change the Path (where you want to export the POL files)
'Setting DblCarrierColumnRelativeColumn to determine what column within RngSourceData _
contains the StrCarrierColumnHeader. If no such column is found, the subroutine is terminated.
On Error Resume Next
DblCarrierColumnRelativeColumn = Excel.WorksheetFunction.Match(StrCarrierColumnHeader, RngSourceData.Rows(1), 0)
If Err <> 0 Then
MsgBox "The range " & RngSourceData.Rows(1).Address(False, False) & " contains no column headed " & StrCarrierColumnHeader & ". The subroutine is terminated", vbCritical, "Error"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
Set RngRange01 = RngSourceData.Columns(DblCarrierColumnRelativeColumn).Resize(RngSourceData.Rows.Count - 1).Offset(1, 0)
DblCounter01 = 0
For Each RngTarget In RngRange01.Cells
If Excel.WorksheetFunction.CountIf(RngSourceData.Parent.Range(RngRange01.Cells(1, 1), RngTarget), RngTarget.Value) = 1 Then
If Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx") = "" Then
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx"
Else
'Is it does exist, the name is "shifted".
DblCounter02 = 2
Do Until Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx") = ""
DblCounter02 = DblCounter02 + 1
Loop
'Carrier and relative file are copied in StrMultipleFileMessage.
StrMultipleFileMessage = StrMultipleFileMessage & vbCrLf & RngTarget.Value & " in " & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
End If
'Setting RngRange02 to target the range in the new file where RngSourceData will be copied.
Set RngRange02 = WkbTarget.Sheets(1).Range("A1").Resize(RngSourceData.Rows.Count, RngSourceData.Columns.Count)
With RngRange02
'Copying values.
RngSourceData.Copy RngRange02
'Filtering the range to clear the list of unwanted data.
.AutoFilter Field:=DblCarrierColumnRelativeColumn, Criteria1:="<>" & RngTarget.Value
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearContents
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearFormats
'Removing the filter.
.AutoFilter
'Rename sheet1
Sheets("Sheet1").Name = "POL"
'Autofit
Sheets("POL").UsedRange.Columns.AutoFit
'Sorting the range to compact the data.
With .Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange RngRange02
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Saving and closing WkbTarget.
WkbTarget.Close SaveChanges:=True
End If
'Setting DblCounter01.
DblCounter01 = DblCounter01 + 1
Next
'Enabling screen updating.
Application.ScreenUpdating = True
'Reporting if any carrier had its data reported in a "twin" file.
If StrMultipleFileMessage <> "" Then
StrMultipleFileMessage = "The following carriers had already one or more dedicated files at the given path. Their data were saved accordingly to this list:" & vbCrLf & vbCrLf & StrMultipleFileMessage
MsgBox StrMultipleFileMessage, , "Multiple dedicated files"
End If
End Sub
Sub ExportCreatePOD()
'File names to be created as " & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now()," MM-DD-YYYY ")"
Dim RngSourceData As Range
Dim RngTarget As Range
Dim RngRange01 As Range
Dim RngRange02 As Range
Dim StrCarrierColumnHeader As String
Dim StrSavePath As String
Dim StrMultipleFileMessage As String
Dim DblCarrierColumnRelativeColumn As Double
Dim DblCounter01 As Double
Dim DblCounter02 As Double
Dim WkbSource As Workbook
Dim WkbTarget As Workbook
'Turning off screen updating.
Application.ScreenUpdating = False
'Setting variables.
Set WkbSource = ActiveWorkbook
Set RngSourceData = WkbSource.Sheets("POD").UsedRange
StrCarrierColumnHeader = "Carrier"
StrSavePath = "C:Path\" '=== Path for POD files Change the Path (where you want to export the POD files)
On Error Resume Next
DblCarrierColumnRelativeColumn = Excel.WorksheetFunction.Match(StrCarrierColumnHeader, RngSourceData.Rows(1), 0)
If Err <> 0 Then
MsgBox "The range " & RngSourceData.Rows(1).Address(False, False) & " contains no column headed " & StrCarrierColumnHeader & ". The subroutine is terminated", vbCritical, "Error"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
Set RngRange01 = RngSourceData.Columns(DblCarrierColumnRelativeColumn).Resize(RngSourceData.Rows.Count - 1).Offset(1, 0)
DblCounter01 = 0
For Each RngTarget In RngRange01.Cells
If Excel.WorksheetFunction.CountIf(RngSourceData.Parent.Range(RngRange01.Cells(1, 1), RngTarget), RngTarget.Value) = 1 Then
'Cheking if any file dedicated to the given carrier already exists for today.
If Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx") = "" Then
'If no such file exists, it is created and saved.
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx"
Else
'Is it does exist, the name is "shifted".
DblCounter02 = 2
Do Until Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx") = ""
DblCounter02 = DblCounter02 + 1
Loop
'Carrier and relative file are copied in StrMultipleFileMessage.
StrMultipleFileMessage = StrMultipleFileMessage & vbCrLf & RngTarget.Value & " in " & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
End If
'Setting RngRange02 to target the range in the new file where RngSourceData will be copied.
Set RngRange02 = WkbTarget.Sheets(1).Range("A1").Resize(RngSourceData.Rows.Count, RngSourceData.Columns.Count)
With RngRange02
'Copying values.
RngSourceData.Copy RngRange02
'Filtering the range to clear the list of unwanted data.
.AutoFilter Field:=DblCarrierColumnRelativeColumn, Criteria1:="<>" & RngTarget.Value
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearContents
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearFormats
'Removing the filter.
.AutoFilter
'Rename Sheet
Sheets("Sheet1").Name = "POD"
'Autofit
Sheets("POD").UsedRange.Columns.AutoFit
'Sorting the range to compact the data.
With .Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange RngRange02
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Saving and closing WkbTarget.
WkbTarget.Close SaveChanges:=True
End If
'Setting DblCounter01.
DblCounter01 = DblCounter01 + 1
Next
'Enabling screen updating.
Application.ScreenUpdating = True
'Reporting if any carrier had its data reported in a "twin" file.
If StrMultipleFileMessage <> "" Then
StrMultipleFileMessage = "The following carriers had already one or more dedicated files at the given path. Their data were saved accordingly to this list:" & vbCrLf & vbCrLf & StrMultipleFileMessage
MsgBox StrMultipleFileMessage, , "Multiple dedicated files"
End If
End Sub
Since you are copying all the data, filtering and then deleting unwanted records I suspect the problem is with the data. Try this more direct approach of copying only what you want.
Option Explicit
Sub ExportCreateBoth()
Call ExportCreateFile("POD")
Call ExportCreateFile("POL")
End Sub
Sub ExportCreateFile(ws_name As String)
Const COL_NAME = "Carrier"
Const SAVEPATH = "C:\temp\so\" ' ouput folder
Dim wb As Workbook, wbOut As Workbook
Dim ws As Worksheet, wsOut As Worksheet
Dim rng As Range, r As Long
Dim iCol As Integer, iLastCol As Integer, iLastRow As Long
Dim filename As String, msg As String
Set wb = ActiveWorkbook
Set ws = wb.Sheets(ws_name)
iLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = ws.Range("A1").Resize(1, iLastCol).Find(COL_NAME)
If rng Is Nothing Then
msg = "The range " & ws.Rows(1).Address() & " contains no column headed " _
& COL_NAME & ". The subroutine is terminated"
MsgBox msg, vbCritical
Exit Sub
End If
' carrier column
iCol = rng.Column
iLastRow = ws.Cells(Rows.Count, iCol).End(xlUp).Row
Set rng = ws.Range("A1").Resize(iLastRow, iLastCol)
' create list of unique values
Dim dict, key
Set dict = CreateObject("Scripting.Dictionary")
For r = 2 To iLastRow
key = Trim(ws.Cells(r, iCol))
If Len(key) > 0 Then dict(key) = 1
Next
' create workbooks for each carrier
Application.ScreenUpdating = False
For Each key In dict.keys
' create output workbook
filename = GetFileName(SAVEPATH, key, ws_name, msg)
Set wbOut = Workbooks.Add
Set wsOut = wbOut.Sheets(1)
wsOut.Name = ws_name
' copy filtered data
rng.AutoFilter Field:=iCol, Criteria1:=CStr(key)
rng.SpecialCells(xlCellTypeVisible).Copy _
wsOut.Range("A1")
wsOut.UsedRange.Columns.AutoFit
wbOut.SaveAs filename
wbOut.Close False
rng.AutoFilter
Next
Application.ScreenUpdating = True
If Len(msg) > 0 Then
msg = "The following carriers had already one or more " & _
"dedicated files at the given path. " & _
"Their data were saved accordingly to this list:" & msg & vbCrLf
MsgBox msg, vbExclamation, "Multiple dedicated files"
End If
MsgBox dict.Count & " files created for " & ws_name, vbInformation
End Sub
Function GetFileName(folder, carrier, str, ByRef msg) As String
Const EXT = ".xlsx"
Dim mdy As String, filename As String, s As String, n As Integer
mdy = Format(Now(), " MM-DD-YYYY ")
filename = folder & carrier & " - " & str & " - " & mdy
s = filename & EXT
n = 1
Do Until Dir(s) = ""
s = filename & "(" & n & ")" & EXT
n = n + 1
Loop
If n > 1 Then
msg = msg & vbLf & carrier & " in " & s
End If
GetFileName = s
End Function

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

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

Generate XML File with VBA

I'm trying to generate an XML file with VBA code.
My goal is to alter Excel data, and then to export this data into a valid XML file. There's only one row of data and one row for the name of the tags which I want to have the data inside.
How can I run through all the data and generate an XML file?
Some sample data (My original file has more columns and data).
(The yellow data is my first block in XML and the green data my second block.)
Here's how the XML File should look:
<?xml version="1.0" encoding="UTF-8"?>
<NmLoader>
<csvBeginTypeDefView handler ="TypeDefinition">
<csvattTemplate>LW</csvattTemplate>
<csvnameSpace>default</csvnameSpace>
<csvname>Tires</csvname>
<csvcontainerDomain/>
<csvtypeParent>Wheels</csvtypeParent>
</csvBeginTypeDefView>
<csvBeginAttributeDefView handler = "AttributeDefinition">
<csvname>TiresAT</csvname>
<csvattDefClass>Definition</csvattDefClass>
<csvdatatype>String</csvdatatype>
<csvIBA>TiresAT</csvIBA>
<csvQoM/>
</csvBeginAttributeDefView>
</NmLoader>
My Code:
Public Sub GenerateXML()
Dim sht As Worksheet
Dim loLetzteZ As Long, loLetzteS As Long, i As Long
Dim rBereich As Range, rng As Range
Dim sTagO As String, sTagC As String, sTagOEnd As String, sTagCStart As String
Dim sZeile As String
Dim strPfad As String
Dim strText As String
sTagO = "<"
sTagOEnd = "/>"
sTagC = ">"
sTagCStart = "</"
Set sht = Worksheets("Data")
'determine the last possible row
loLetzteZ = sht.Cells(Rows.Count, 1).End(xlUp).Row
'determine the last possible column
loLetzteS = sht.Cells(1, Columns.Count).End(xlToLeft).Column
'set me the area for the complete worksheet
Set rBereich = sht.Range("A2:" & Cells(loLetzteZ, loLetzteS).Address)
Application.ScreenUpdating = False
strPfad = ActiveWorkbook.Path & "\Data" & ".xml"
'row for row
For Each rng In rBereich.Rows
With rng
'column for column
For i = 1 To .Columns.Count
'If the tag is empty, then close this
If IsEmpty(.Cells(1, i)) Then
sZeile = sZeile & sTagO & Cells(1, i) & sTagOEnd
Else
'Opening Tag
sZeile = sZeile & sTagO & Cells(1, i) & sTagC
'Data for the tags
sZeile = sZeile & .Cells(1, i)
'End of Tags
sZeile = sZeile & sTagCStart & Cells(1, i) & sTagC
End If
'Write line with distance
sZeile = sZeile & vbCrLf
Next
'Write line with distance
sZeile = sZeile & vbCrLf & vbCrLf
'Open file and write the text
Call InDateiSchreiben(strPfad, sZeile, True)
End With
Next
Application.ScreenUpdating = True
End Sub
Other Solutions I tried:
I've already mapped the XML with Excel, but Excel is not able to export such an XML Schema.
I wrote code in VBA (I'm a beginner) by looking through posts regarding an XML Export.
Try this
Function GetXmlElement(sTagName As String, _
sValue As String, _
Optional bUseEmptyTags As Boolean = False, _
Optional bMultiline As Boolean = False) As String
Dim sStartOpen As String: sStartOpen = "<"
Dim sClose As String: sClose = ">"
Dim sEndOpen As String: sEndOpen = "</"
Dim sEmptyClose As String: sEmptyClose = " />"
Dim sTab As String: sTab = " "
Dim sTagValSeparator As String
Dim sValTagSeparator As String
If bMultiline Then
sTagValSeparator = Chr(10) & sTab
sValTagSeparator = Chr(10)
End If
If Len(sValue) = 0 And bUseEmptyTags Then
GetXmlElement = sStartOpen & sTagName & sEmptyClose
Else
GetXmlElement = sStartOpen & sTagName & sClose & sTagValSeparator & _
Replace(sValue, Chr(10), Chr(10) & sTab) & _
sValTagSeparator
If InStr(1, sTagName, " ") > 0 Then
'tag has attributes'
sTagName = Left(sTagName, InStr(1, sTagName, " ") - 1)
End If
GetXmlElement = GetXmlElement & sEndOpen & sTagName & sClose
End If
End Function
Function GetXMLOutput() As String
Dim lLastCol As Long
Dim i As Long
Dim lCsvBeginCol As Long
Dim sTagName As String
Dim sInnerElements As String
Dim sOutput As String
With ThisWorkbook.Sheets("Data")
lLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
lCsvBeginCol = 1
For i = 1 To lLastCol
sTagName = .Cells(1, i)
If Left(sTagName, 8) = "csvBegin" And i > lCsvBeginCol Or i = lLastCol Then
' build the outer element
sTagName = .Cells(1, lCsvBeginCol) & "=""" & .Cells(2, lCsvBeginCol) & """"
If Len(sOutput) > 0 Then
sOutput = sOutput & Chr(10) & Chr(10)
End If
sOutput = sOutput & GetXmlElement(sTagName, sInnerElements, True, True)
lCsvBeginCol = i
sInnerElements = ""
ElseIf i <> lCsvBeginCol Then
' build the inner elements
If Len(sInnerElements) > 0 Then sInnerElements = sInnerElements & Chr(10)
sInnerElements = sInnerElements & GetXmlElement(sTagName, .Cells(2, i), True)
End If
Next i
sOutput = GetXmlElement("NmLoader", sOutput, True, True)
sOutput = "<?xml version=""1.0"" encoding=""UTF-8""?>" & Chr(10) & Chr(10) & sOutput
GetXMLOutput = sOutput
Debug.Print sOutput
End With
End Function
Sub GenerateXML()
Dim sFilename As String
sFilename = ThisWorkbook.Path & "\Data.xml"
Open sFilename For Output As #1
Print #1, GetXMLOutput
Close #1
End Sub
Try
Option Explicit
Public Sub GenerateXML()
Dim sht As Worksheet
Set sht = Worksheets("Data")
Dim loLetzteZ As Long, loLetzteS As Long, i As Long
Dim rBereich As Range, rng As Range
Dim sZeile As String
Dim strPfad As String
Dim sTag As String, sTag1 As String, sData As String
'determine the last possible row
loLetzteZ = sht.Cells(Rows.Count, 1).End(xlUp).Row
'determine the last possible column
loLetzteS = sht.Cells(1, Columns.Count).End(xlToLeft).Column
'set me the area for the complete worksheet
Set rBereich = sht.Range("A2:" & Cells(loLetzteZ, loLetzteS).Address)
' output
strPfad = ActiveWorkbook.Path & "\Data" & ".xml"
sTag1 = ""
sZeile = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf _
& "<NmLoader>" & vbCrLf
'row for row
For Each rng In rBereich.Rows
With rng
'column for column
For i = 1 To .Columns.Count
sTag = Trim(sht.Cells(1, i))
sData = Trim(.Cells(1, i))
'If the tag is handler
If LCase(Right(sTag, 7)) = "handler" Then
sTag1 = Split(sTag, " ")(0) ' remove handler
sZeile = sZeile & "<" & sTag1 & " handler=""" & sData & """>"
' is it a closing tag
ElseIf sTag = sTag1 Then
sZeile = sZeile & "</" & sTag1 & ">" & vbCrLf
ElseIf Len(sData) > 0 Then
sZeile = sZeile & vbTab & "<" & sTag & ">" & sData & "</" & sTag & ">"
Else
sZeile = sZeile & vbTab & "<" & sTag & "/>"
End If
sZeile = sZeile & vbCrLf
Next
'Write line with distance
sZeile = sZeile & vbCrLf & "</NmLoader>" & vbCrLf
'Open file and write the text
Debug.Print sZeile
'Call InDateiSchreiben(strPfad, sZeile, True)
End With
Next
MsgBox strPfad & " created", vbInformation
End Sub

Save as pdf destination issues

I am working on a save to pdf export from a loop function. I have set the file_name as:
Sub AutoFill_export2pdf()
'
Dim rowCount As Integer
Dim CurBU As String
Dim CurOPRID As String
Dim CurName As String
Dim CurJournalID As String
Dim CurJournalDate As String
Dim FILE_NAME As String
Sheets("List").Select
rowCount = ActiveSheet.UsedRange.Rows.count
Set Destsh = ActiveWorkbook.Sheets("Sheet")
For sourceRow = 2 To rowCount
CurOPRID = Range("A" & CStr(sourceRow)) 'OPRID
CurName = Range("B" & CStr(sourceRow)) 'Name
CurBU = Range("C" & CStr(sourceRow)) 'BU
CurJournalID = Range("D" & CStr(sourceRow)) 'Journal ID
CurJournalDate = Range("E" & CStr(sourceRow)) 'Journal Date
FILE_NAME = ActiveWorkbook.Path & "\" & "OTGL_" & "JRNL_" & CurBU & "_" & CurJournalID & "_" & Format(CurJournalDate, "mm-dd-yyyy") & "_" & ".PDF"
CurName = "*" & CurName & "*"
CurBU = "*" & CurBU & "*"
CurJournalID = "*" & CurJournalID & "*"
CurJournalDate = "*" & CurJournalDate & "*"
Destsh.Range("K27") = CurName
Destsh.Range("D7") = CurBU
Destsh.Range("G7") = CurJournalID
Destsh.Range("I7") = CurJournalDate
On Error GoTo 0
Call SaveAsPDF(Destsh, FILE_NAME)
Sheets("List").Select
Next
End Sub
Public Sub SaveAsPDF(ByVal destSheet As Worksheet, ByVal PDFName As String)
On Error Resume Next
Kill PDFName
destSheet.Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=FILE_NAME, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
Sub Autofill()
'
Dim rowCount As Integer
Dim CurBU As String
Dim CurName As String
Dim CurOPRID As String
Dim CurJournalID As String
Dim CurJournalDate As String
Dim FILE_NAME As String
CurName = "*" & CurName & "*"
CurBU = "*" & CurBU & "*"
CurJournalID = "*" & CurJournalID & "*"
CurJournalDate = "*" & CurJournalDate & "*"
Sheets("List").Select
rowCount = ActiveSheet.UsedRange.Rows.count
Set Destsh = ActiveWorkbook.Sheets("Sheet")
For sourceRow = 2 To rowCount
CurOPRID = Range("A" & CStr(sourceRow)) 'OPRID
CurName = Range("B" & CStr(sourceRow)) 'Name
CurBU = Range("C" & CStr(sourceRow)) 'BU
CurJournalID = Range("D" & CStr(sourceRow)) 'Journal ID
CurJournalDate = Range("E" & CStr(sourceRow)) 'Journal Date
FILE_NAME = ActiveWorkbook.Path & "\" & "OTGL_" & "JRNL_" & CurBU & "_" & CurJournalID & "_" & Format(CurJournalDate, "mm-dd-yyyy") & "_" & ".PDF"
Destsh.Range("K27") = CurName
Destsh.Range("D7") = CurBU
Destsh.Range("G7") = CurJournalID
Destsh.Range("I7") = CurJournalDate
On Error GoTo 0
Call SaveAsPDF(Destsh, FILE_NAME)
Sheets("List").Select
Next
End Sub
The goal is to export to a specific folder with the naming convention I have established. If you need the entire macro, please let me know.
In the interest of teaching to fish vs handing out fish...
Put option explicit at the very top (even before your first sub).
Open your locals window (View in the VBE). Step through your code with F8, watching your variables in the locals window to ensure that they are what you expect them to be at that step in your script.
Option explicit will identify numberous variables that you haven't
declared. ("Variable not defined")
Fix those and any other issues that come up. (When it goes to other subs it will ID issues with variables there also.)
Your issue might go away just fixing what option explicit identifies and/or it might become apparent stepping through your code and watching the locals window each time you hit F8.
If you are still stuck, then edit your post with your updated code and explain any error message and line it is occurring on. If there isn't an error explain the expected and actual behavior.
The above code works perfectly, the file I was working off of was a copy with an identical name saved in the temp folder, so all the files were saving into the active workbook path..which wasnt in the folder I was monitoring. I have about 30000 pdfs in there now from running the macro so many times, lol! Thanks to all who tried to help.

Resources