Create a script to create xml with a button press

[sherihe]

Hi all,

Thanks for your help in advance...

I need to create a macro that takes the below information in Excel and converts it to a XML Data (.xml) file and saves it to the desktop with a push of a button. 3 columns (id, questRes1, questRes2) will be filled out for each question. I entered 3 rows as an example, but the user may fill in 100+ rows.

id	questRes1	questRes2
cp23	I prefer to work in a relaxed environment	I enjoy working under pressure
ac12	I'd rather move on than spend time double-checking work	I am precise in my work
comp12	I find competitive situations demotivating	I like to compete and do everything I can to win

The final result would need to look like the following:

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<surveydata xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<questions>
<question id="cp23">
<questRes1>I prefer to work in a relaxed environment</questRes1>
<questRes2>I enjoy working under pressure</questRes2>
</question>
<question id="ac12">
<questRes1>I'd rather move on than spend time double-checking work</questRes1>
<questRes2>I am precise in my work</questRes2>
</question>
<question id="comp12">
<questRes1>I find competitive situations demotivating</questRes1>
<questRes2>I like to compete and do everything I can to win</questRes2>
</question>
</questions>
</surveydata>


Thanks!

Sheri

 

[Zack Barresse]

Hi there,

You could use something like the below code. Make sure to change your sheet and range reference how you want it. Obviously assumes three columns of data.

Option Explicit


Sub ExportAsXML()
    
    Dim Sheet As Worksheet
    Dim ColumnIndex As Long
    Dim FileNumber As Integer
    Dim LastRow As Long
    Dim RowIndex As Long
    Dim StartRow As Long
    Dim FileText As String
    Dim TempFilePath As String
    Dim FilePath As Variant
    Dim Values As Variant
    
    Const OverwriteFile As Boolean = True
    
    Set Sheet = ThisWorkbook.Worksheets("Sheet1")
    LastRow = Sheet.Cells(Sheet.Rows.Count, 1).End(xlUp).Row
    FilePath = Application.GetSaveAsFilename(InitialFileName:="filename.xml", FileFilter:="XML File (*.xml),*.xml")
    If FilePath = False Then Exit Sub
    
    If ExistingFile(FilePath) Then
        If Not OverwriteFile Then Exit Sub
        DeleteFile FilePath
        If ExistingFile(FilePath) Then
            MsgBox "Check your permissions. Previous file not deleted.", vbExclamation + vbOKOnly, "Ruh roh"
            Exit Sub
        End If
    End If
    TempFilePath = FilePath & ".txt"
    
    Values = Sheet.Range("A1:C" & LastRow).Value
    StartRow = LBound(Values, 1) + 1
    
    AppendLine FileText, "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>"
    AppendLine FileText, "<surveydata xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">"
    AppendLine FileText, "<questions>"
    
    For RowIndex = StartRow To UBound(Values, 1)
        AppendLine FileText, "<question " & Values(1, 1) & "=""" & Values(RowIndex, 1) & """>"
        AppendLine FileText, "<" & Values(1, 2) & ">" & Values(RowIndex, 2) & "</" & Values(1, 2) & ">"
        AppendLine FileText, "<" & Values(1, 3) & ">" & Values(RowIndex, 3) & "</" & Values(1, 3) & ">"
    Next RowIndex
    
    AppendLine FileText, "</questions>"
    AppendLine FileText, "</surveydata>"
    
    FileNumber = FreeFile()
    Open TempFilePath For Output As #FileNumber
    Print #FileNumber, FileText
    Close #FileNumber
    Name TempFilePath As FilePath
    
    If ExistingFile(FilePath) Then
        MsgBox "Data exported successfully.", vbInformation + vbOKOnly, "Woohoo!"
    Else
        MsgBox "Something went horribly wrong.", vbCritical + vbOKOnly, "Uhhhhhh"
    End If
    
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Helper Functions

Public Sub AppendLine( _
        ByRef Text As String, _
        Optional ByVal NewLine As String _
    )

    AppendToken Text, NewLine, vbCrLf

End Sub


Public Sub AppendToken( _
        ByRef Text As String, _
        ByVal NewToken As String, _
        Optional ByVal Delimiter As String = ", " _
    )

    Text = Text & IIf(Len(Text) = 0, vbNullString, Delimiter) & NewToken

End Sub


Public Function DeleteFile( _
       ByVal FilePath As String _
    ) As Boolean

    On Error Resume Next
    If ExistingFile(FilePath) Then Kill FilePath
    If Err.Number = 0 Then DeleteFile = True
    Err.Clear

End Function


Public Function ExistingFile( _
       ByVal FilePath As String _
       ) As Boolean

    Dim Attributes As Integer

    On Error Resume Next
    Attributes = GetAttr(FilePath)
    ExistingFile = (Err.Number = 0) And (Attributes And vbDirectory) = 0
    Err.Clear

End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

 

[sherihe]

Thank you, Zack! This looks awesome and saved me hours of trying to figure this out on my own. REALLY appreciate you taking the time to write up the code. If you have a few more minutes to spare, I have one last question...How do I append </question> to the end of each item (see in red text below). That's the only thing I'm missing.

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<surveydata xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<questions>
<question id="cp23">
<questRes1>I prefer to work in a relaxed environment</questRes1>
<questRes2>I enjoy working under pressure</questRes2>
</question>
<question id="ac12">
<questRes1>I'd rather move on than spend time double-checking work</questRes1>
<questRes2>I am precise in my work</questRes2>
</question>
<question id="comp12">
<questRes1>I find competitive situations demotivating</questRes1>
<questRes2>I like to compete and do everything I can to win</questRes2>
</question>
</questions>
</surveydata>

 

[sherihe]

Never mind, figured it out! Have a great evening.

 

[Zack Barresse]

Ah, I did forget that part, didn't I. Apologies. Glad you got it figured out!

 

[sherihe]

No worries! Thanks again for the assist! It really helped.