[已解决]vba输出xml文件

france723

如图EXCEL所示, 在工作表"01"中有A,B两列信息 (内容可变) . A列为<Num>, B列为<Name>.
现在想用vba输出xml文件, 如图XML所示.
跪求大神帮忙vba输出xml文件

最佳答案

月排行榜 / 总排行榜

Excel学徒123

2017-4-24 16:59

1. 
   
2. Sub SaveXML()
   
3.     If MsgBox("Are you sure create xml?", vbYesNo) = vbYes Then
   
4.         ActiveWorkbook.Save
   
5.         Dim xlsname, filepath
   
6.         Dim irow%, icol%
   
7.         xlsname = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
   
8.         filepath = ThisWorkbook.Path
   
9.         Dim objStream As Object
   
10.         Set objStream = CreateObject("ADODB.Stream")
    
11.         objStream.Open
    
12.         objStream.Position = 0
    
13.         objStream.Charset = "UTF-8"
    
14.         objStream.writetext "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf
    
15.         objStream.writetext "<Formats> " & vbCrLf
    
16.         For irow = 1 To Cells(Rows.Count, 1).End(3).Row
    
17.             objStream.writetext vbTab & "<Format>" & vbCrLf
    
18.             objStream.writetext vbTab & vbTab & "<Num>" & Cells(irow, 1) & "</Num>" & vbCrLf
    
19.             objStream.writetext vbTab & vbTab & "<Name>" & Cells(irow, 2) & "</Name>" & vbCrLf
    
20.             objStream.writetext vbTab & "</Format>" & vbCrLf
    
21.         Next
    
22.         objStream.writetext "</Formats>" & vbCrLf
    
23.          
    
24.         objStream.SaveToFile filepath + "" + xlsname + ".xml", 2
    
25.         objStream.Close
    
26.         Set objStream = Nothing
    
27.     End If
    
28. End Sub
    

复制代码

跳转到最佳答案楼层

QCW911

有现成的函数，查查Excel转换XML

QCW911

另存就可以

france723

QCW911 发表于 2017-4-24 16:32
有现成的函数，查查Excel转换XML

这是我Project的一部分, 想用VBA来实现. 但还是谢谢你

Excel学徒123

1. 
   
2. Sub SaveXML()
   
3.     If MsgBox("Are you sure create xml?", vbYesNo) = vbYes Then
   
4.         ActiveWorkbook.Save
   
5.         Dim xlsname, filepath
   
6.         Dim irow%, icol%
   
7.         xlsname = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
   
8.         filepath = ThisWorkbook.Path
   
9.         Dim objStream As Object
   
10.         Set objStream = CreateObject("ADODB.Stream")
    
11.         objStream.Open
    
12.         objStream.Position = 0
    
13.         objStream.Charset = "UTF-8"
    
14.         objStream.writetext "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf
    
15.         objStream.writetext "<Formats> " & vbCrLf
    
16.         For irow = 1 To Cells(Rows.Count, 1).End(3).Row
    
17.             objStream.writetext vbTab & "<Format>" & vbCrLf
    
18.             objStream.writetext vbTab & vbTab & "<Num>" & Cells(irow, 1) & "</Num>" & vbCrLf
    
19.             objStream.writetext vbTab & vbTab & "<Name>" & Cells(irow, 2) & "</Name>" & vbCrLf
    
20.             objStream.writetext vbTab & "</Format>" & vbCrLf
    
21.         Next
    
22.         objStream.writetext "</Formats>" & vbCrLf
    
23.          
    
24.         objStream.SaveToFile filepath + "" + xlsname + ".xml", 2
    
25.         objStream.Close
    
26.         Set objStream = Nothing
    
27.     End If
    
28. End Sub
    

复制代码

france723

Excel学徒123 发表于 2017-4-24 16:59

老师,您的代码很好用. 有三个小问题希望你能修改一下:

• 第二行<Config Version="1">没有写入
• 保存的时候, 自定义保存地点和文件名字 (就像我们平时保存文档)
• 文档很多工作表, 只在"01"这一页执行这个操作
  

Excel学徒123

france723 发表于 2017-4-24 17:17
老师,您的代码很好用. 有三个小问题希望你能修改一下:

第二行没有写入

保存的时候, 自定义保存地 ...

这个小问题就自己改了吧，自定义另存的代码那么多，还有version那个自己在外层加入进去就可以了

france723

Excel学徒123 发表于 2017-4-24 17:23
这个小问题就自己改了吧，自定义另存的代码那么多，还有version那个自己在外层加入进去就可以了

版主, version那个和<MachineName>BW46</MachineName> 加入, 没有达到预计效果.
新手求帮助

Excel学徒123

france723 发表于 2017-4-24 21:07
版主, version那个和BW46 加入, 没有达到预计效果.
新手求帮助

vbtab的原因吧，自己找找