如何从Excel VBAmacros中生成XML？

所以，我收到了很多以Excel电子表格的forms发送给我们的内容。 我需要把这个内容带入另一个系统。 另一个系统从XML文件中获取input。 我可以手工完成这一切（并相信我，pipe理没有问题，让我这样做！），但我希望有一个简单的方法来编写一个Excelmacros，可以生成我需要的XML。 这对我来说似乎是一个更好的解决scheme，因为这是一个需要定期重复的工作（我们将在Excel工作表中获得大量内容），并且有一个批处理工具可以帮助我们。

不过，我从来没有尝试过从Excel电子表格生成XML。 我有一点VBA的知识，但我是XML的新手。 我猜我的问题在Google上search，我甚至不知道Google要做什么。 任何人都可以给我一个方向，让我开始？ 我的想法听起来像是解决这个问题的正确方法，还是我忽略了一些明显的东西？

感谢StackOverflow！

Answer 1

请参阅在VBA中将Excel导出为XML以获取帮助。

Answer 2

您可能会考虑ADO – 工作表或范围可以用作表格。

Const adOpenStatic = 3 Const adLockOptimistic = 3 Const adPersistXML = 1 Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") ''It wuld probably be better to use the proper name, but this is ''convenient for notes strFile = Workbooks(1).FullName ''Note HDR=Yes, so you can use the names in the first row of the set ''to refer to columns, note also that you will need a different connection ''string for >=2007 strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _ & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";" cn.Open strCon rs.Open "Select * from [Sheet1$]", cn, adOpenStatic, adLockOptimistic If Not rs.EOF Then rs.MoveFirst rs.Save "C:\Docs\Table1.xml", adPersistXML End If rs.Close cn.Close 

Answer 3

信贷：curiousmind.jlion.com/exceltotextfile（链接不再存在）

脚本：

 Sub MakeXML(iCaptionRow As Integer, iDataStartRow As Integer, sOutputFileName As String) Dim Q As String Q = Chr$(34) Dim sXML As String sXML = "<?xml version=" & Q & "1.0" & Q & " encoding=" & Q & "UTF-8" & Q & "?>" sXML = sXML & "<rows>" ''--determine count of columns Dim iColCount As Integer iColCount = 1 While Trim$(Cells(iCaptionRow, iColCount)) > "" iColCount = iColCount + 1 Wend Dim iRow As Integer iRow = iDataStartRow While Cells(iRow, 1) > "" sXML = sXML & "<row id=" & Q & iRow & Q & ">" For icol = 1 To iColCount - 1 sXML = sXML & "<" & Trim$(Cells(iCaptionRow, icol)) & ">" sXML = sXML & Trim$(Cells(iRow, icol)) sXML = sXML & "</" & Trim$(Cells(iCaptionRow, icol)) & ">" Next sXML = sXML & "</row>" iRow = iRow + 1 Wend sXML = sXML & "</rows>" Dim nDestFile As Integer, sText As String ''Close any open text files Close ''Get the number of the next free text file nDestFile = FreeFile ''Write the entire file to sText Open sOutputFileName For Output As #nDestFile Print #nDestFile, sXML Close End Sub Sub test() MakeXML 1, 2, "C:\Users\jlynds\output2.xml" End Sub 

Answer 4

这一个更多的版本 – 这将有助于通用

 Public strSubTag As String Public iStartCol As Integer Public iEndCol As Integer Public strSubTag2 As String Public iStartCol2 As Integer Public iEndCol2 As Integer Sub Create() Dim strFilePath As String Dim strFileName As String 'ThisWorkbook.Sheets("Sheet1").Range("C3").Activate 'strTag = ActiveCell.Offset(0, 1).Value strFilePath = ThisWorkbook.Sheets("Sheet1").Range("B4").Value strFileName = ThisWorkbook.Sheets("Sheet1").Range("B5").Value strSubTag = ThisWorkbook.Sheets("Sheet1").Range("F3").Value iStartCol = ThisWorkbook.Sheets("Sheet1").Range("F4").Value iEndCol = ThisWorkbook.Sheets("Sheet1").Range("F5").Value strSubTag2 = ThisWorkbook.Sheets("Sheet1").Range("G3").Value iStartCol2 = ThisWorkbook.Sheets("Sheet1").Range("G4").Value iEndCol2 = ThisWorkbook.Sheets("Sheet1").Range("G5").Value Dim iCaptionRow As Integer iCaptionRow = ThisWorkbook.Sheets("Sheet1").Range("B3").Value 'strFileName = ThisWorkbook.Sheets("Sheet1").Range("B4").Value MakeXML iCaptionRow, iCaptionRow + 1, strFilePath, strFileName End Sub Sub MakeXML(iCaptionRow As Integer, iDataStartRow As Integer, sOutputFilePath As String, sOutputFileName As String) Dim Q As String Dim sOutputFileNamewithPath As String Q = Chr$(34) Dim sXML As String 'sXML = sXML & "<rows>" ' ''--determine count of columns Dim iColCount As Integer iColCount = 1 While Trim$(Cells(iCaptionRow, iColCount)) > "" iColCount = iColCount + 1 Wend Dim iRow As Integer Dim iCount As Integer iRow = iDataStartRow iCount = 1 While Cells(iRow, 1) > "" 'sXML = sXML & "<row id=" & Q & iRow & Q & ">" sXML = "<?xml version=" & Q & "1.0" & Q & " encoding=" & Q & "UTF-8" & Q & "?>" For iCOl = 1 To iColCount - 1 If (iStartCol = iCOl) Then sXML = sXML & "<" & strSubTag & ">" End If If (iEndCol = iCOl) Then sXML = sXML & "</" & strSubTag & ">" End If If (iStartCol2 = iCOl) Then sXML = sXML & "<" & strSubTag2 & ">" End If If (iEndCol2 = iCOl) Then sXML = sXML & "</" & strSubTag2 & ">" End If sXML = sXML & "<" & Trim$(Cells(iCaptionRow, iCOl)) & ">" sXML = sXML & Trim$(Cells(iRow, iCOl)) sXML = sXML & "</" & Trim$(Cells(iCaptionRow, iCOl)) & ">" Next 'sXML = sXML & "</row>" Dim nDestFile As Integer, sText As String ''Close any open text files Close ''Get the number of the next free text file nDestFile = FreeFile sOutputFileNamewithPath = sOutputFilePath & sOutputFileName & iCount & ".XML" ''Write the entire file to sText Open sOutputFileNamewithPath For Output As #nDestFile Print #nDestFile, sXML iRow = iRow + 1 sXML = "" iCount = iCount + 1 Wend 'sXML = sXML & "</rows>" Close End Sub