VBA で XML 読み込み (だれ需要やねん・・・)

#はじめに
書類を作成する際に、別紙として XML の内容を Excel に落として
提出するのですが、新規や大きく修正するファイルに関しては、
手入力だと めんどくさい 内容を記載するのに間違いがある可能性がある。
また、Excel 標準だと求めているものと違うため(既存フォーマットあり)、読み込み用の処理を作成した。

※ついでに書き出しも作っているが、それはまた別の時に。
※XMLの元ファイルがインデント付けていたりと見やすさ重視にされているのですが書き出しはその辺り出来んので。

#1.出力に必要な情報

1)既存であるフォーマットに合わせる。

　・B列→ルートノード

　・C列〜J列→タグ名 (8階層分。可変可能)

　なお、結合する(列と行)

　・K列→属性

　１行目には値の内容を入れ、２行目から属性値を入力する。

　・L列→値

　・M,N列→更新フラグ

　・更新フラグは入力規則で選択

　・入力有無で、書式設定する

2)出力シートにマクロボタンを配置する。

　・XML 読み込み

　・内容削除

　　 ※動作確認して特に問題がなさそうなので、ソースは修正しない。

#2.マクロボタン処理
内容削除は、ヘッダ部分以外を削除するので、特に記載しない。

○XML 読み込み
1)シートチェック
　シート内にデータが残っていないかチェックする。
　方法は色々ありますが、仕様上、終端を全部結合してEOFといれるため、
　それがあるかのチェックと、B9（ルート書き出し位置）にデータの有無をチェックするのみです。

Check_Sheet=255 '関数名
Dim EndRange As Range: Set EndRange = Columns.Find(What:="EOF", LookIn=xValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If(EndRange is Nothing) = False Then
 Check_Sheet= -1
 Exit Function
End If
If Range("B9").Value <> "" Then
 Check_Sheet= -2
 Exit Function
End If
Check_Sheet=0

戻り値が０以外は、問題があるため出力メッセージを表示します。

2)読み込みファイルをダイアログを開いて指定する
　XMLファイルをダイアログを開いて指定します。

Call OpenStartFolder 'ダイアログを開いたときのフォルダを設定する。Excel実行位置と同じところとする
Dim OpenFileName As String
OpenFileName = Application.GetOpenFilename(FileFilter:="xmlファイル", Title:="読み込みXMLファイルを選択してください。やめる時はキャンセルを押してください。")

If OpenFileName = "False" Then
 MsgBox("中止します")
 Exit Sub
End If

〜略〜
Public Sub Set_OpenStartFolder()
 Dim StartPath As String
 StartPath = Application.THisWorkbook.Path
 If Left(StartPath, 2) <> "¥¥" Then
  ChDrive Left(StartPath, 1)
  ChDir StartPath
 Else
  With CreateObject("WScript.SHell")
   .CurrentDirectory = StartPath
  End With
 End If
End Sub

3)読み込み処理開始
　読み込みを開始します。
　なお、クラスモジュールを作成して行なっております。
　※Sheet用のオブジェ内にベタっと書くのが嫌だったので。。。

Application.ScreenUpdating = False '処理軽減

Dim clsLoadXml As ClsLoadtoXML: Set clsLoadXml = New ClsLoadtoXML
Dim rtnCode As Long
rtnCode = clsLoadXml.cls_LoadXml(OpenFileName) 'class 内の処理呼び出し。引数はXMLファイル
If(clsLoadXml As Nothing) = False Then Set clsLoadml = Nothing

Application.ScreenUpdating = True

と、rtnCode はこちらで設定します。
rtnCode を見て、問題ないかメッセージ出力してます。

1. クラス内の読み込み処理
   　クラス内で読み込み処理を行いますが、関数で分割しています。
   　主に以下の通り

関数名	用途
Class_Initialize	Classが作成された際の初期処理
Class_Terminate	Classが破棄された際の処理
cls_LoadXml	XML読み込みとrootノードの書き出し、その後配下の設定関数呼出
LoadXmlData	XML読込成否を返却
Set_RootNode	ルートノードの出力
Set_TagDatas	ルートノード配下の出力
RecursiveProcessingforDomLists	タグデータ作成(なお、再起処理)
Set_EOF	最終行の設定
Set_FormSettingForCondition	条件付き書式の設定
Set_DataInputList	入力規則リストデータの設定
Set_CellBorders	セル罫線設定
ChangeColumnNum	列番号変換

4-1)XML読込メイン関数
　Sheet側から呼び出されてXML読込の処理を行います。

Public Function cls_LoadXml(Byval argFilePath As String) As Long
 cls_LoadXml = 255
 Dim xmlDocument As MSXML2.DOMDocument60
 Call LoadXmlData(argFilePath, xmlDocument)
 If xmlDocument.parseError.ErrorCode <> 0 Then
  cls_LoadXml = -1
  Exit Function
 End If

　まず、XML読込を行います。LoadXmlData関数を呼び出し、エラーコードチェックを行います。
　関数の引数には、XMLファイルパスと、XMLの読み込んだ内容を返却してもらう変数を設定します。

　LoadXmlData関数は以下の通り。

Private Function LoadXmlData(Bevel argLoadFile As String, ByRef argtmpXmlDoc As MSXML2.DOMDocument60)
 Set argtmpxmlDoc = New MSXML2.DOMDocument60
 argtmpXmlDoc.async = False
 argtmpXmlDoc.Load(argLoadFile)
Exit Function

4-2)次に、開始位置の設定をします。

 Dim iPosRow As Integer: iPosRow = POS_START -1
 Dim strTarget As String: strTarget = Tag1_COL + CStr(iPosRow)
 Dim selRange: Set SelRange = Range(strTarget)

 Dim MergeCells As Integer: MergeCell = SelRange.MergeArea.Columns.Count
 MergeCells = MergeCells -1
 ReDim aryCntPos(MergeCells)

 Dim iColCnt As Integer

 For iColCnt = 0 To MergeCells
  arycntPos(iColCnt) = ChangeColumnNum(SelRange.Row, SelRange.Column + iColCnt)
 Next
 '属性値以降の位置設定
 strATTRCol = ChangeColumnNum(SelRange.Row, SelRange.Column + iColCnt)
 iColCnt = iColCnt + 1
 strVALUCol = ChangeColumnNum(SelRange.Row, SelRange.Column + iColCnt)
 iColCnt = iColCnt + 1
 strUPYNCol = ChangeColumnNum(SelRange.Row, SelRange.Column + iColCnt)
 iColCnt = iColCnt + 1
 strRESVCol = ChangeColumnNum(SelRange.Row, SelRange.Column + iColCnt)
 iColCnt = iColCnt + 1
 'タグ名最終行設定
 EndTagPoinst = aryCntPos(UBound(aryCntPos))

　4行目：タグ名のところの結合数を見て判断します。基本8階層ですが、増やす時用に判定入れてます。
　8行目：配列にAやBなどを数値から変換して入れてます。
　属性値以降の設定も同様に。。。

　ChangeColumnNum 関数を呼び出し

Private Function ChangeColumnNum(strArgRow, iArgCol) As String
 Dim buf
 buf = Cells(strArgRow, iArgCol).Address(True, False)
 ChangeColumnNum = Left(buf, Instr(buf, "$") -1)
End Function

4-3)引数に、行番号と列番号を指定して、それを元に、Columnのみに変換します。
　　そういえば、間にstrATTRCol など出てきますが、外部変数となります。
　　また定数も宣言してます。
　　※うまいことやったら外部変数いらなかった気もしますが、作った時は無理そうってなったので。

　　それらは以下の通り。

'定数宣言
Const POS_START As Integer = 9
Const ROOT_COL As String = "B"
Const Tag1_COL As String = "C"

'外部変数宣言
Private PosRow As Integer
Private PosCol As String
Private MergeEndRow As Integer
Private attrCnt As Integer
Private arySuf As Integer
Private aryCntPos() As String
Private baseName As String
Private EndTagPoinst As String
Private strATTRCol As String
Private strVALUCol As String
Private strUPYNCol As String
Private strRESVCol As String

4-4)そして、ルートノード出力・ルートノード配下出力・最終行設定・
　　条件付き書式などせってを行なって終了です。

 'ルートノード出力
 cls_LoadXml = Set_RootNode(xmlDocument)
 If cls_LoadXml <> 0 Then Exit Function
 'ルートノード配下出力
 cls_LoadXml = Set_TagDatas(xmlDocument)
 If(xmlDocument Is Nothing) = False Then Set xmlDocument = Nothing
 If cls_LoadXml <> 0 Then Exit Function
 '最終行設定
 Call Set_EOF
 '条件付き書式・属性・値の設定
 Call Set_FormSettingForCondition
 cls_LoadXml = 0
End Function

4-5)各関数を呼び出して実行します。
　　罫線は、やりながら設定させてます。（処理は後ほど）

　　Set_RootNode　関数の中身は以下の通り。

Private Function Set_RootNode(ByVal argXmlDoc As MSXML2.DOMDoument60) As Long
 set_RootNode = 255
 baseName = argXmlDoc.DocumentElement.nodeName
 'ルートノードを設定
 Dim xmlDomSelect As MSXML2.IXMLDOMNodeList: Set xmlDomSelect = argXmlDoc.SelectNodes(baseName)
 '初期設定
 attrCnt = xmlDomSelect.Item(0).Attributes.Length
 PosCol = ROOT_COL
 PosRow = POS_START
 MergeEndRow = POS_START + attrCnt
 'ルートノードの値をセルに設定
 ActiveSheet.Range(ROOT_COL & PosRow).Value = baseName
 Call Set_CellBorders(PosCol & PosRow & ":" & EndTagPoinst & MergeEndRow, True, False, False, "")
 Call Set_CellBorders(strATTRCol & PosRow, False, True, False, "")
 Call Set_CellBorders(strVALUCol & PosRow, False, True, False, "")
 'ルートノード以降の位置設定
 PosRow = PosRow + 1
 '属性地の設定
 Dim xmlDomAttr As Variant
 If attrCnt > 0 Then
  For Each xmlDomAttr In xmlDomSelect.Item(0).Attributes
   Call Set_CellBorders(strATTRCol & PosRow, False, True, False, xmlDomAttr.Name)
   Call Set_CellBorders(strVALUCol & PosRow, False, True, False, xmlDomAttr.Value)
   PosRow = PosRow + 1
   Next
  End If
 If(xmlDomSelect Is Nothing) = False Then Set xmlDomSelect = nothing
 Set_RootNode = 0
End Function

　ノードリストを採取し、ルートノードの設定（属性・値）を行なってます。
　Set_CellBorders では、罫線を引いています。
　また、属性値名・値(属性も含む)をセルに設定してやってます。

'ARG1:対象セル、対象セル範囲
'ARG2:結合フラグ
'ARG3:xlDiagonalUpフラグ
'ARG4:横位置センターフラグ
'ARG5:セル設定値
Private Sub Set_CellBorders(ByVal argRangeal As String, _
                            ByVal argMergeFlg As Boolean, _
                            ByVal argxDUpFlg As Boolean, _
                            ByVal argHAcFlg As Boolean, _
                            ByVal argSetVal As String)
 With ActiveSheet.Range(argRangeal)
  '結合と値の設定
  If argMergeFlg = True Then .Merge
  If argSetVal <> "" Then .Value = argSetVal
  '縮小設定は行う
  .ShrinkToFit = True
  '文字のセンター設定
  If argHAcFlg = True Then .HorizontalAlignment = xCenter
  '上下左右罫線設定
  .Borders(xlEdgeTop).LineStyle = xlContinuous
  .Borders(xlEdgeBottom).LineStyle = xlContinuous
  .Borders(xlEdgeRight).LineStyle = xlContinuous
  .Borders(xlEdgeLeft).LineStyle = xlContinuous
  '斜め右上罫線設定
  If argDUpFlg = True Then .Borders(xlDiagonalUp).LineStyle = xlContinuous
 End With
End If

　
　次、ルートノード配下を出力します。
　ルートノード配下のタグ名のColumnは配列で管理されており、それをずらして出力していく形となります。
　出力の方法が同じだったので、再起処理で行います。

'ルートノード配下出力
Private Function Set_TagDatas(ByVal argxmlDomSel As MSXML2.DOMDocument60) As Long
 set_TagDatas = 255
 Dim xmlDomSel As MSXML2.IXMLDOMNodeList: Set xmlDomSel = argxmlDomSel.SelectNodes(baseName)
 DimDomlists As Variant

 arySuf = 0
 PosCol = aryCntPos(arySuf)

 For Each Domlists In xmlDomSel.Item(0).ChildNodes
  Set_TagDatas = RecursiveProcessingforDomLists(Domlists)
 Next
 Set_TagDatas = 0
End Function

　ノードをとってきて、ループで回して出力するわけだが・・・
　ChildNodesって１個だけな気がするなっと。
　次、再起処理内でCellに設定している内容となります。

Private Function RecursiveProcessingforDomLists(argDomList As Variant) As Long
 RecursiveProcessingforDomLists = 255

 '値格納先と、斜め罫線・センターのフラグ
 Dim tmpVal As String
 Dim tmpDxUp As Boolean
 Dim tmpargHAc As Boolean
 'コメント行以外は出力する
 If argDomList.NodeType <> NODE_COMMENT Then
  baseName = argDomList.baseName
  attrCnt = argDomList.Attributes.Length
  MergeEndRow = PosRow + attrCnt
  'タグ名設定
  ActiveSheet.Range(PosCol & PosRow).Value = baseName
  Call Set_CellBorders(argRangeVal:=PosCol & PosRow & ":" & EndTagPoinst & MergeEndRow, argMergeFlg:=True, argxDUpFlg:=False, argHAcFlg:=False,argSetVal:="")

  'タグ属性設定
  Call Set_CellBorders(strATTRCol & PosRow, False, True, False, "")
  '設定する値があるかないかで分岐させる。
  If argDomList.ChildNodes.Length = 1 Then
   tmpVal = argDomList.ChildNodes.Item(0).Text
   tmpDxUp = False
   tmpargHAc = True
  Else
   tmpVal = ""
   tmpDxUp = False
   tmpargHAc = True
  End If

  Call Set_CellBorders(argRangeVal:=strVALUCol & PosRow, argMergeFlg:=False, argxDUpFlg:= tmpDxUp, argHAcFlg:= tmpargHAc,argSetVal:=tmpVal)

 Else
  Call Set_CellBorders(strVALUCol & PosRow, False,True, False, "")
 End If

 PosRow = PosRow + 1

 '属性値が存在する場合は設定する
 If attrCnt <> 0 Then
  Dim int As Integer
  For iCnt = 0 To attrCnt -1
   Call Set_CellBorders(argRangeVal:=strATTRCol & PosRow, argMergeFlg:=False, argxDUpFlg:= False, argHAcFlg:= True,argSetVal:=argDomList.Attributes.Item(iCnt).baseName)

   'Cell値の設定
   If argDomList.Attributes.Item(iCnt).ChildNodes.Length <> 0 Then
    tmpVal = argDomList.Attributes.Item(iCnt).ChildNodes.Item(0).Text
   Else
    tmpVal = "値なし"
   End If

   Call Set_CellBorders(argRangeVal:=strVALUCol & PosRow, argMergeFlg:=False, argxDUpFlg:= False, argHAcFlg:= True,argSetVal:=tmpVal)

   PosRow = PosRow + 1
  Next
 End If

 '次のノードがある場合は出力する
 If argDomList.ChildNodes.Length > 0 Then
  If argDomList.ChildNodes.Item(0).NodeType <> NODE_TEXT Then
   arySuf = arySuf +1
   PosCol = aryCntPos(arySuf)

   Dim cldCnt As Integer
   For cldCnt = 0 To argDomList.ChildNodes.Length -1
    Call RecursiveProcessingforDomLists(argDomList.ChildNodes.Item(cldCnt))
   next
   arySuf = arySuf - 1
   PosCol = aryCntPos(arySuf)
  End If
 End If
 End If

 RecursiveProcessingforDomLists = 0
End Function

　1行ずつ書き出していく形となります。
　タグ名の左右（C〜J）をずらして出力していくイメージです。

　全て終わったら戻り、最終行を出力します。

Private Sub Set_EOF()
 With ActiveSheet.Range(ROOT_COL & PosRow & ":" & strRESVCol & PosRow)
  .Merge
  .Font.Size = 16
  .Interior.Color = RGB(0, 128, 0)
  .Font.Bold = True
 End With
 'EOF行の設定
 Call Set_CellBorders(argRangeVal:=ROOT_COL & PosRow & ":" & strRESVCol & PosRow, argMergeFlg:=False, argxDUpFlg:= False, argHAcFlg:= True,argSetVal:="EOF")
 '全体の枠作成
 Call Set_CellBorders(argRangeVal:=ROOT_COL & POS_START & ":" strRESVCol & PosRow, argMergeFlg:=False, argxDUpFlg:= False, argHAcFlg:= False,argSetVal:="")

　フォントサイズとか、背景色などはお好みというところです。

　次、条件付き書式設定となります。
ルート名・タグ名・属性・値・更新有無のところの設定となります。
　が・・・カラーレイアウトとかは特に記載しません。

Private Sub Set_FormSettingForConDition()
 Dim setRow As Integer
 Dim aryData As Variant
 Dim arySetPos() As String
 ReDim arySetPos(UBound(aryCntPos) + 1)
 Dim i As Integer
 '１回目はルートを設定しそれ以外はタグ名の位置を設定する
 For i = 0 To UBound(arySetPos)
  If i = 0 Then
   arySetPos(i) = ROOT_COL
  Else
   arySetPos(i) = aryCntPos(i-1)
  End If
 Next
 '開始位置設定
 setRow = POS_START
 'PosRow=最終までループで１行ずつ設定していく
 Do While setRow < PosRow
  'タグ名の値が入っていないところを背景灰色にする
  '入ってるところは結合されている
  For Each aryData In arySetPos
   With ActiveSheet.Range(aryData & setRow)
    If .MergeCells = False Then
     .Interior.Color = RGB(192,192,192)
    Else
     Exit For
    End With
  Next

  '属性・値・更新有無の条件付き書式設定
  Dim tmpRange As String
  '属性値設定
  tmpRange = Range(strATTRCol & setRow).Address(0,1)
  With Range(tmpRange)
   .Active
   .FormatConditions.Delete
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "="""""
   .FormatConditions(1).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(1).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "<>"""""
   .FormatConditions(2).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(2).StopIfTrue = True
  End With
  '値設定
  tmpRange = Range(strVALUCol & setRow).Address(0,1)
  With Range(tmpRange)
   .Active
   .FormatConditions.Delete
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "=""変更不要箇所"""
   .FormatConditions(1).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(1).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "="""""
   .FormatConditions(2).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(2).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "<>"""""
   .FormatConditions(3).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(3).StopIfTrue = True
  End With
  '変更有無の設定
  tmpRange = Range(strUPYNCol & setRow).Address(0,1)
  Call Set_DataInputList(tmpRange)
  With Range(tmpRange)
   .Active
   .FormatConditions.Delete
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "=""変更不要箇所"""
   .FormatConditions(1).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(1).Font.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(1).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "=""削除"""
   .FormatConditions(2).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(2).Bold = True
   .FormatConditions(2).Font.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(2).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "=""追加"""
   .FormatConditions(3).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(3).Bold = True
   .FormatConditions(3).Font.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(3).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "=""変更あり"""
   .FormatConditions(4).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(4).Bold = True
   .FormatConditions(4).Font.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(4).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "=""変更なし"""
   .FormatConditions(5).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(5).Bold = True
   .FormatConditions(5).Font.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(5).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "<>"""""
   .FormatConditions(6).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(6).StopIfTrue = True
  End With

  Call Set_CellBorders(argRangeVal:=strUPYNCol & setRow, argMergeFlg:=False,argxDUPFlg=False,argxDUpFlg:=False,argHAcFlg:="True,argSetal:="")
  '変更有無の　Revision　設定
  tmpRange = Range(strRESVCol & setRow).Address(0,1)
  With Range(tmpRange)
   .Active
   .FormatConditions.Delete
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "="""""
   .FormatConditions(1).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(1).StopIfTrue = True
   .FormatConditions.Add Type:=xlExpression, Formula1:="=" & strATTRCol & setRow & "<>"""""
   .FormatConditions(2).Interior.Color = RGB(xxx,xxx,xxx)
   .FormatConditions(2).StopIfTrue = True
  End With

  Call Set_CellBorders(argRangeVal:= strRESVCol & setRow, argMergeFlg:=False,argxDUPFlg=False,argxDUpFlg:=False,argHAcFlg:="True,argSetal:="")

  setRow = setRow + 1
 Loop
End Sub

　もう一個忘れてました。
　入力規則のリストの内容設定。

Private Sub Set_DataInputList(argRange As String)
 With ActiveSheet.Range(argRange).Validation
  .Delete
  .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="変更なし,変更あり,追加,削除,変更不要箇所"
 End With
End Sub

　最後に、先頭行とコンストラクタ・デストラクタは以下の通り。

Option Explicit
〜略〜
Public Sub Class_Initialize()
 Cells.Select
 With Selection.Font
  .Name = "Meiryo UI"
  .Size = 10
 End With
 Range("A1").Select
End Sub
Public Sub Class_Terminate()
 Range("A1").Select
End Sub

#まとめ
正直、Excel VBA で行う人なんて、もうほとんどいないと思いますが、
やる人がいる場合の参考ということで。

しかし、所々、関数のByVal 設定がないところがあるけど・・それでも動くから仕方ない。

後は、作ったの１年ぐらい前なので、処理の内容をちゃんと覚えてないので説明が出来ない（笑）

＜追記＞
大事なこと忘れてましたが、
6000行ぐらい、130KBほどのファイルの出力に２０分ぐらいかかります。
削除時もおなじぐらいかかってたな・・・。
そのため、他の作業ができなくなったり、落ちたことはないですが、怖いので、他のExcelは閉じておくべきですね。