Excel to XML

xx

Option Explicit
Dim myFile, file
Dim intResult
Function valueToXML(value As Variant, elementLabel)
'   Function wraps value in XML tags per elementLabel
'   If value is empty then nothing is returned
'   If value is 'NULL' then an empty XML element is returned
    
    valueToXML = ""
    If value <> "" Then
        valueToXML = "<" & elementLabel & ">"
        If value <> "NULL" Then valueToXML = valueToXML & value
        valueToXML = valueToXML & "</" & elementLabel & ">"
    End If
End Function
Function valueDateToXML(value, elementLabel)
'   Function wraps value in XML tags per elementLabel
'   If value is empty then nothing is returned
'   If value is 'NULL' then an empty XML element is returned
'   if target is a date as per isdate the is formatted as YYYY-MM-DD
    valueDateToXML = ""
    If value <> "" Then
        ' condition should still allow 'NULL' to fall through
        If IsDate(value) Then _
            value = Year(value) & "-" & _
            Format(Month(value), "00") & "-" & _
            Format(Day(value), "00")
        valueDateToXML = valueToXML(value, elementLabel)
    End If
End Function
Function valueToXMLAttribute(value As Variant, attributeLabel) As String
'   Function creates XML attribute
'   If value is empty then nothing is returned
'   If value is 'NULL' then an empty attribute is returned
    valueToXMLAttribute = ""
    If value <> "" Then
        valueToXMLAttribute = " " & attributeLabel & "="""
        If value <> "NULL" Then valueToXMLAttribute = valueToXMLAttribute & value
        valueToXMLAttribute = valueToXMLAttribute & """"
    End If
End Function
Function concatenateRangeObjectToXML(range As Variant, elementLabel)
'   Function concatenates the cells in the supplied range & wraps that in XML tags per elementLabel
'   If range is empty then nothing is returned
    Dim vArr As Variant
    Dim rows, cols, x, y
    vArr = range
    Dim haveData
    
    haveData = False
    concatenateRangeObjectToXML = ""
    
    rows = UBound(vArr, 1)
    cols = UBound(vArr, 2)
    
    ' Check if any data
    For x = 1 To rows
        For y = 1 To cols
            If vArr(x, y) <> "" Then
                haveData = True
                Exit For
            End If
        Next
        If haveData Then Exit For
    Next
    
    If haveData Then
        concatenateRangeObjectToXML = "<" & elementLabel & ">"
        
        For x = 1 To rows
            For y = 1 To cols
                If vArr(x, y) <> "" Then concatenateRangeObjectToXML = concatenateRangeObjectToXML & vArr(x, y)
            Next
        Next
        concatenateRangeObjectToXML = concatenateRangeObjectToXML & "</" & elementLabel & ">"
    End If
    
End Function
Function concatenateRange(range As Variant)
'   Function concatenates the range supplied
    Dim vArr As Variant
    Dim rows, cols, x, y
    vArr = range
    concatenateRange = ""
    
    rows = UBound(vArr, 1)
    cols = UBound(vArr, 2)
        
    For x = 1 To rows
        For y = 1 To cols
            If vArr(x, y) <> "" Then concatenateRange = concatenateRange & vArr(x, y)
        Next
    Next
    
End Function
Function getMyDocumentsPath() As String
    ' Function returns path to my documents folder
    
    Dim objFSO As Object
    Dim objShell As Object
    Dim objFolder As Object
    Dim objFolderItem As Object
    
    Const MY_DOCUMENTS = &H5&
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    
    Set objFolder = objShell.Namespace(MY_DOCUMENTS)
    Set objFolderItem = objFolder.Self
    getMyDocumentsPath = objFolderItem.Path
    
End Function
Sub XMLOutputMakeFileItems()
    XMLOutputOpenTargetFile
    XMLOutputOpenWriteHeaders
    XMLOutputWriteItems
    XMLOutputWriteFooterAndClose
    
    intResult = MsgBox("Cells output to " & myFile, vbOKOnly, "Ready")
    
End Sub
Private Sub XMLOutputOpenTargetFile()
    ' Needs VBA -> Tools -> References -> Microsoft Scripting
    Dim myFso As New FileSystemObject
    
    myFile = getMyDocumentsPath() & "\_xmlout.xml"
    Set file = myFso.CreateTextFile(myFile)
    
End Sub
Private Sub XMLOutputOpenWriteHeaders()
    
    file.WriteLine (range("XML_file_top").value)
End Sub
Private Sub XMLOutputWriteFooterAndClose()
    
    file.WriteLine (range("XML_file_bottom").value)
    file.Close
End Sub
Private Sub XMLOutputWriteItems()
    Dim rCell
    
    range("XML_testdata_items").SpecialCells(xlCellTypeVisible).Select
    For Each rCell In Selection
        If rCell.value <> "" Then file.WriteLine (rCell.value)
    Next rCell
End Sub
Sub ExcelCopyItems()
    range("Excel_testdata").SpecialCells(xlCellTypeVisible).Copy
End Sub

xxx