Advertisement
aFilthy-Casual

VBA (Excel) Convert Table into xml

Jan 16th, 2022 (edited)
1,046
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. 'GitHub Repository: https://github.com/Anton-Stechman/ConvertExcelTableToXml
  2. 'VBA for Excel - Convert a Table into an xml file
  3. 'Version 0.2.0
  4.  
  5. Private filename As String
  6. Private filepath As String
  7. Private xmlStr As String
  8. Private HideFile As Boolean
  9. Private CurAddrs As String
  10. Private NoCellErrors As Boolean
  11.  
  12. 'Initial Macro - Call From a Button
  13. Sub RunXmlExport()
  14.     'Add Optional Inputs Here, e.g., Call BeginMainLoop(CustomPath:="C:\Users\user\Documents\")
  15.    Call BeginMainLoop
  16. End Sub
  17.  
  18. 'Used as a Helper to Set Variables Before Entering the MainLoop
  19. Private Sub BeginMainLoop(Optional CustomPath As String = vbNullString, Optional CustomFile As String = vbNullString, _
  20. Optional DataRange As String = vbNullString, Optional HeadRange As String = vbNullString)
  21.     If CustomPath <> vbNullString Then: filepath = CustomPath
  22.     If CustomFile <> vbNullString Then: filename = CustomFile
  23.     If DataRange = vbNullString Then: DataRange = "TableName[#All]" 'Replace With TableName Target Table Name e.g., Table1[#All]
  24.    If HeadRange = vbNullString Then: HeadRange = "TableName[#Headers]" 'Replace With TableName Target Table Name e.g., Table1[#Headers]
  25.    HideFile = True
  26.     Call MainLoop(tblHeaders:=HeadRange, tblData:=DataRange)
  27. End Sub
  28.  
  29. 'Main Loop
  30. Private Sub MainLoop(Optional tblHeaders As String = vbNullString, Optional tblData As String = vbNullString)
  31.     On Error GoTo Error_Handle
  32.     If filepath = vbNullString Then: filepath = Range("TargetPath").Value 'Can Change Path Here
  33.    If Right(filepath, 1) <> "\" Then: filepath = filepath & "\"
  34.     If DirExists(filepath) = False Then: MkDir (filepath)
  35.     If filename = vbNullString Then: DateVal = Format(Now, "YYYY-MM"): filename = DateVal & "_MBM_SourceData.xml" 'Can Change filename here
  36.    Call OptimiseVBA
  37.     xmlStr = FormatForXml(HeaderRow:=Range(tblHeaders), TableRange:=Range(tblData))
  38.     Call CreateNewXml(CStr(xmlStr))
  39.     Call SetAttr(filepath & filename, IIf(HideFile = True, vbHidden, vbNormal))
  40.     Call MsgBox("xml Export Complete!" & vbNewLine & "Press 'Ok' To Finish", vbOKOnly, "Success!")
  41.     Call OptimiseVBA(True)
  42.     Debug.Print (xmlStr)
  43.     Exit Sub
  44.    
  45. Error_Handle:
  46.     Call MsgBox("An Error Occured!" & vbNewLine & "Error Number:" & Space(1) & _
  47.     Err.Number & vbNewLine & "Description:" & Space(1) & Err.Description & _
  48.     IIf(CurAddrs <> vbNullString, vbNewLine & "Error in Cell:" _
  49.     & Space(1) & CurAddrs, vbNullString), vbOKOnly, "Error!")
  50.     Call OptimiseVBA(True)
  51. End Sub
  52.  
  53. 'Format Target Range Values For XML
  54. Private Function FormatForXml(Optional HeaderRow As Range, Optional TableRange As Range, Optional MaxIterations As Integer = 1000) As String
  55.     'Set Variables
  56.    Dim str As String
  57.     Dim Q As String: Q = Chr$(34)
  58.    
  59.     'Initiate xml Format
  60.    str = "<?xml version=" & Q & "1.0" & Q & Space(1) & "encoding=" & Q & "UTF-8" & Q & "?>" & vbNewLine
  61.     str = str & "<SourceDataTable>" & vbNewLine
  62.                                        
  63.     'Format Input Table for xml
  64.    For i = 1 To TableRange.Rows.Count
  65.         str = str & vbTab & "<SourceData>" & vbNewLine
  66.         For Each h In HeaderRow
  67.             Dim newHeader: newHeader = ReplaceChar(CStr(h.Value))
  68.             If newHeader = vbNullString Then: newHeader = "blank_field_Col" & h.Column
  69.             With h.Offset(i, 0)
  70.                 CurAddrs = .Address
  71.                 If IsEmpty(.Value) Then: v = "null": Else v = .Value
  72.             End With
  73.             str = str & vbTab & vbTab & "<" & newHeader & ">" & v & "</" & newHeader & ">" & vbNewLine
  74.         Next h
  75.         str = str & vbTab & "</SourceData>" & vbNewLine
  76.         If i >= MaxIterations Then: Exit For
  77.     Next i
  78.    
  79.     'Close off xml formatting
  80.    str = str & "</SourceDataTable>" & vbNewLine
  81.     str = Replace(str, "_>", ">")
  82.     str = Replace(str, "<>", "<blank_field>")
  83.     str = Replace(str, "</>", "</blank_field>")
  84.     FormatForXml = str
  85.     NoCellErrors = True
  86. End Function
  87.  
  88. 'Generate XML File
  89. Private Sub CreateNewXml(contents As String)
  90.     If DirExists(filepath & filename) = False Then: Call SetAttr(filepath & filename, vbNormal)
  91.     Dim objStream
  92.     Set objStream = CreateObject("ADODB.Stream")
  93.     objStream.Charset = "UTF-8"
  94.     objStream.Open
  95.     Call objStream.WriteText(contents)
  96.     Call objStream.SaveToFile(filepath & filename, 2)
  97.     objStream.Close
  98. End Sub
  99.  
  100. 'Remove Illegal Characters
  101. Private Function ReplaceChar(str As String) As String
  102.     ReplaceChar = Replace(str, " ", "_")
  103.     ReplaceChar = Replace(ReplaceChar, ".000", vbNullString)
  104.     For i = 1 To 47
  105.         ReplaceChar = Replace(ReplaceChar, Chr$(i), vbNullString)
  106.     Next i
  107.     For i = 58 To 64
  108.         ReplaceChar = Replace(ReplaceChar, Chr$(i), vbNullString)
  109.     Next i
  110.     If IsNumeric(Left(ReplaceChar, 1)) = True Then
  111.         ReplaceChar = "n" & ReplaceChar
  112.     End If
  113. End Function
  114.  
  115. 'Check Directory Exists
  116. Private Function DirExists(Optional dirStr As String)
  117.     If dirStr = vbNullString Then: dirstring = filepath & "\Data\"
  118.     DirExists = Dir(dirStr, vbDirectory) <> vbNullString
  119. End Function
  120.  
  121. 'Turn VBA Optimisation On/Off
  122. Private Sub OptimiseVBA(Optional switch As Boolean = False)
  123.     Dim calcsettings As Variant
  124.     If switch = True Then: calcsettings = xlAutomatic: Else: calcsettings = xlManual
  125.     Application.ScreenUpdating = switch
  126.     Application.EnableEvents = switch
  127.     Application.Calculation = calcsettings
  128. End Sub
  129.  
  130.  
Advertisement
Advertisement
Advertisement
RAW Paste Data Copied
Advertisement