excel中如何利用VBA批量生成XML文件

定义一个宏，代码如下：

[vb] view plain copy

print?

Sub SaveXML()
If MsgBox("Are you sure create xml?", vbYesNo) = vbYes Then
ActiveWorkbook.Save
Dim xlsname, filepath
xlsname = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
filepath = ThisWorkbook.Path
Dim objStream As Object
Set objStream = CreateObject("ADODB.Stream")
objStream.Open
objStream.Position = 0
objStream.Charset = "UTF-8"
objStream.WriteText "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf
objStream.WriteText "<" & xlsname & "> " & vbCrLf
For Each sh In ActiveWorkbook.Worksheets
Dim rng As Range
Set rng = sh.Range("A1")
Dim count1, count2, count3
count1 = 2
count2 = 2
count3 = 0
Dim columnName As String
If rng.Offset(1, 1) = "Child" Then
ElseIf rng.Offset(1, 1) = "" Then
objStream.WriteText vbTab & "<" & sh.Name & "s>" & vbCrLf
objStream.WriteText vbTab & "</" & sh.Name & "s>" & vbCrLf
Else
objStream.WriteText vbTab & "<" & sh.Name & "s>" & vbCrLf
Do While rng.Offset(count1, 0) <> ""
objStream.WriteText vbTab & vbTab & "<" & sh.Name
Do While rng.Offset(2, count3) <> ""
columnName = rng.Offset(1, count3)
If InStr(1, columnName, "_") <> 0 Then
objStream.WriteText " " & Right(columnName, Len(columnName) - InStr(1, columnName, "_")) & "=" & """"
objStream.WriteText rng.Offset(count1, count3) & """"
End If
count3 = count3 + 1
Loop
count3 = 0
objStream.WriteText "/>" & vbCrLf
count1 = count1 + 1
Loop
MsgBox ("555555")
count1 = 2
count2 = 2
objStream.WriteText vbTab & "</" & sh.Name & "s>" & vbCrLf
End If
Next
objStream.WriteText "</" & xlsname & ">" & vbCrLf
objStream.SaveToFile filepath + "\" + xlsname + ".xml", 2
objStream.Close
Set objStream = Nothing
End If
End Sub

本站仅提供存储服务，所有内容均由用户发布，如发现有害或侵权内容，请点击举报。