Private Sub ToXML()
'定义所需类型
Dim Filename As Variant
Dim TDOpenTag As String
Dim CellContents As String
Dim Rng As Range
Dim r As Long, c As Integer
'定义保存名称和类型
Filename = Application.GetSaveAsFilename( _
InitialFileName:="ButtonTextList.xml", _
fileFilter:="XML Files(*.xml), *.xml")
If Filename = False Then Exit Sub
'定义输出缩写
Open Filename For Output As #1
Print #1, "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>"
Print #1, "<BUFF模板表 xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">"
'循环sheets
For i = 1 To 1
'设置单元格范围
Set Rng = Worksheets(i).Range("A1:AN1000")
For r = 2 To Rng.Rows.Count
' 判断Excel中下一行是否有数据
If Rng.Cells(r, 1) = "" Then
Exit For
End If
Print #1, " <" & Rng.Cells(r, 1) & ">"
For c = 2 To Rng.Columns.Count
'判断Excel中当前行的下一列是否有数据
If Rng.Cells(r, c) = "" Then
Rng.Cells(r, c) = 0
End If
Print #1, " <" & Rng.Cells(1, c) & ">";
If IsDate(Rng.Cells(r, c)) Then
Print #1, Format(Rng.Cells(r, c), "yyyy-mm-dd");
Else
Print #1, Rng.Cells(r, c).Text;
End If
Print #1, "</" & Rng.Cells(1, c) & ">"
Next c
Print #1, " </" & Rng.Cells(r, 1) & ">"
Next r
Next i
Print #1, "</BUFF模板表>"
'关闭
Close #1
'保存
MsgBox Rng.Rows.Count - 1 & " records were exported to " & Filename
End Sub