[Office][Excel] 輕鬆使用Excel轉出XML檔

2010-11-25

51199
0
Office
2013-07-14

最近有朋友因為要使用Blend中利用XML做DataBinding的功能，需要想辦法生出XML檔，但是資料量不少，不可能自己動手Key，也不想為了這個小需求就再安裝其他編輯XML的工具，問我有沒有什麼比較簡單的方法，我就想到我之前好像也有用VBA寫過可以將Excel中的工作表資料匯出成XML檔的功能，果然皇天不負苦心人，在被我封印而且忘記有它存在的資料夾中被我找到了，特別再拿出來跟大家分享(不過事過境遷，我已經快完全忘記VBA該怎麼寫了，如果有問題需要修改的話請別鞭我)。

該程式碼如下(當初好像是參考一個外國人寫的範例，但是我改了不少地方)：

'匯出XML檔
Sub ExportXml()
 
Dim defaultFolder As String
 
Dim myRow As Integer
Dim myColumn As Integer
 
Dim xmlFileName As String
Dim xmlRecordName As String
 
Dim lineFinish As String
 
Dim rangeToProcess As Integer
 
Dim range1 As String
Dim range2 As String
 
Dim fieldName(99) As String
 
lineFinish = Chr(10) & Chr(13)
 
defaultFolder = "C:\"
 
 
xmlFileName = ReplaceSpace(InputBox("請輸入要儲存的XML檔名：", "匯出XML檔", "MyXmlFile"))
 
If Right(xmlFileName, 4) <> ".xml" Then
 
    xmlFileName = xmlFileName & ".xml"
 
End If
 
xmlRecordName = ReplaceSpace(InputBox("請輸入每筆資料實體的名稱：", "匯出XML檔", "Data"))
 
range1 = InputBox("請輸入資料名稱欄位範圍：", "匯出XML檔", "A1:F1")
 
If RefineRange(range1, 1) <> RefineRange(range1, 2) Then
 
    MsgBox "錯誤： 資料名稱欄位只能包含一列" & lineFinish & "作業中止", vbOKOnly + vbCritical, "匯出XML檔"
    Exit Sub
    
End If
 
myRow = RefineRange(range1, 1)
 
For myColumn = RefineRange(range1, 3) To RefineRange(range1, 4)
 
    If Len(Cells(myRow, myColumn).Value) = 0 Then
        
        MsgBox "錯誤： 資料名稱欄位包含空白欄位" & lineFinish & "作業中止", vbOKOnly + vbCritical, "匯出XML檔"
        
        Exit Sub
        
    End If
    
    fieldName(myColumn - RefineRange(range1, 3)) = ReplaceSpace(Cells(myRow, myColumn).Value)
 
Next myColumn
 
range2 = InputBox("請輸入資料欄位範圍：", "匯出XML檔", "A2:F11")
 
If RefineRange(range1, 4) - RefineRange(range1, 3) <> RefineRange(range2, 4) - RefineRange(range2, 3) Then
 
  MsgBox "錯誤： 資料欄位數目與資料名稱欄位數目不符" & lineFinish & "作業中止", vbOKOnly + vbCritical, "匯出XML檔"
  
  Exit Sub
  
End If
 
rangeToProcess = RefineRange(range2, 3)
 
If InStr(1, xmlFileName, ":\") = 0 Then
 
 xmlFileName = defaultFolder & xmlFileName
 
End If
 
 
Dim myStreamObject As Object
 
Set myStreamObject = CreateObject("ADODB.Stream")
 
myStreamObject.Open
myStreamObject.Position = 0
myStreamObject.Charset = "UTF-8"
 
myStreamObject.WriteText "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-8" & Chr(34) & "?>", 1
myStreamObject.WriteText "<DataCollection>", 1
 
For myRow = RefineRange(range2, 1) To RefineRange(range2, 2)
    
    myStreamObject.WriteText "<" & xmlRecordName & ">", 1
    
    For myColumn = rangeToProcess To RefineRange(range2, 4)
    
        myStreamObject.WriteText "<" & fieldName(myColumn - rangeToProcess) & ">" & RemoveAmpersands(CheckFormat(myRow, myColumn)) & "</" & fieldName(myColumn - rangeToProcess) & ">", 1
        
    Next myColumn
     
    myStreamObject.WriteText "</" & xmlRecordName & ">", 1
 
Next myRow
 
myStreamObject.WriteText "</DataCollection>", 1
 
myStreamObject.SaveToFile xmlFileName, 2
 
myStreamObject.Close
 
MsgBox xmlFileName & " 建立完成。", vbOKOnly + vbInformation, "匯出XML檔"
 
End Sub
'重新取得範圍
Function RefineRange(rangeText As String, item As Integer) As Integer
' analyse a range, where item represents 1=TR, 2=BR, 3=LHC, 4=RHC
 
Dim newRange As Range
 
Set newRange = Range(rangeText)
 
Select Case item
    Case 1
        RefineRange = newRange.Row
    Case 2
        RefineRange = newRange.Row + newRange.Rows.Count - 1
    Case 3
        RefineRange = newRange.Column
    Case 4
        RefineRange = newRange.Columns(newRange.Columns.Count).Column
End Select
Exit Function
 
End Function
'處理特殊符號
Function RemoveAmpersands(inputString As String) As String
 
Dim myPosition As Integer
 
myPosition = InStr(1, inputString, "&")
 
Do While myPosition > 0
 
    Mid(inputString, myPosition, 1) = "+"
    
    myPosition = InStr(1, inputString, "&")
    
Loop
 
RemoveAmpersands = inputString
 
End Function
'重新格式化數值與日期欄位
Function CheckFormat(rowNumber As Integer, columnNumber As Integer) As String
 
CheckFormat = Cells(rowNumber, columnNumber).Value
 
If IsNumeric(Cells(rowNumber, columnNumber).Value) Then
    
    CheckFormat = Format(Cells(rowNumber, columnNumber).Value, "#,##0 ;(#,##0)")
    
End If
 
If IsDate(Cells(rowNumber, columnNumber).Value) Then
    
    CheckFormat = Format(Cells(rowNumber, columnNumber).Value, "YYYY/mm/dd")
    
End If
 
End Function
'將空白字元以底線取代
Function ReplaceSpace(inputString As String) As String
 
Dim myPosition As Integer
 
myPosition = InStr(1, inputString, " ")
 
Do While myPosition > 0
 
    Mid(inputString, myPosition, 1) = "_"
    
    myPosition = InStr(1, inputString, " ")
    
Loop
 
ReplaceSpace = inputString
 
End Function

這個東西怎麼玩呢?請你跟我這樣做，首先打開你的Excel(我這邊使用的是2010版)，選取檔案->選項->自訂功能區，並且將「開發人員」項目打勾，然後按下確定按鈕。

接著在功能表的Ribbon區你將會看到多出了「開發人員」頁籤。

點選開發人員頁籤中的Visual Basic按鈕，會跳出一個Microsoft Visual Basic for Applications視窗，如下圖：

再來在專案總管視窗的VBAProject上按下滑鼠右鍵，選取插入->模組

然後幫新建立的模組取個名字吧(這個步驟其實不是必需啦，可是我喜歡取名字@__@)

接著把上面的程式碼貼上去，再按下存檔按鈕，會跳出一個對話視窗，這邊千萬別急著按下「是」，要按「否」!!!

按了否之後，會跳出一個另存新檔的視窗，這邊要將存檔類型改為「Excel 啟用巨集的活頁簿(*.xlsm)」格式，再進行存檔。

存完檔之後，就可以把資料貼到工作表裡面，來進行匯出的動作啦!!(只要把這個xlsm檔留起來，以後有資料要轉XML就貼進這個檔裡面轉就不用再重複前面的步驟了)

之後只要叫出Microsoft Visual Basic for Applications視窗，並且按下執行按鈕(或按F5鍵)，並選取執行前面加入的巨集，再依照指示操作，就可以產出一份XML檔啦!!

補充 - 巨集的操作步驟說明：

第一步是輸入要匯出的XML檔檔名，只需要輸入檔名即可。

第二步是輸入資料的名稱

第三步是輸入資料名稱欄的範圍，以上圖為例的話，名稱欄範圍為A1:C1(共計三個欄位)，這邊要注意的是名稱欄的範圍只能有一個Row，而且不能含有空白欄位，不能超過，否則會跳Exception。

最後是輸入資料值的欄位範圍，以上例的話就是A2:C18，這邊一樣要注意的是資料值的欄位Column數不得超過名稱欄範圍的Column數。

最後就打完收工啦!!

最後附上我挖出來的xlsm檔，請自行取用：

回首頁