Excel VBA で XML 出力

はじめに

前回同様、VBAでやる人なんて今いないでしょ？
というところで、処理だけ書き出しておこうと思います。
※こっちは、XMLであってもソースの修正扱いになるので、新規以外は使用しないため、
　不採用という形となった物ですね。

作るときの気持ちとしては「ExcelからXML作成したら便利ーー」
という程度です。

Excel内に設置するマクロボタン

一覧シートを１つ用意し、
シート名を取得、その横に、チェックボックスを設置します。
チェックが入っているシートのXMLのみ出力を行います。
もちろん、内容が間違ってたら勝手に止まりますね。

処理について

1.マクロボタンが押されたら出力するかの確認メッセージ出力
2.XMLファイル名取得
3.出力実施
4.完了メッセージ出力

そういえば、こちらは、出力だけなのでそこまで時間かからず、
重くもなくという状態だったと思います。
※使わなくなって数年・・・。メンテすらしてないです。

本処理

今回も、ベタっと書くのが嫌なのでClass作成しております。
※今回も、といいつつ、作成順は、出力・読込だったりしますね。

ループして、XML出力しているが・・・まぁそのまま書きますね。

Public Sub Click_SaveXml()
 Dim strMsgTitle As String
 Dim lrc As Long

 strMsgTitle = "XMLファイル出力の実行"
 lrc = MsgBox("XML出力するか？", vbOKCancel + vbQuestion, strMsgTitle)

 If lrc <> 1 Then Exit Sub

 Application.ScreenUpdating = False

 '出力リスト作成(シート名一覧からチェックボックスにチェックが入っている分取得)
 Dim iOutputNum As Integer
 'K4 にシート総数が入っている
 iOutPutNum = CInt(Range("K4").Value)
 'H4,I4 から取得した分、配列に格納
 Dim i, iRowCnt As Integer
 Dim strSheetPath As String
 Dim strSheetName As String
 Dim lRslt As Long

 'H,Iの列番号設定
 iRowCnt = 4

 For i = 1 To iOutputNum
  Dim clsSaveXml As ClassSavetoXML
  If strSheetPath = "" Then strSheetPath = ThisWorkbook.Path

  If strComp(Range("H" & iRowCnt).Value, "True") = 0 Then
   Set cls SaveXml = New ClassSavetoXML
   strSheetName = Range("I" & iRowCnt).Value
   Worksheets(strSheetName).Activate
   'シートパスとシート名設定
   clsSaveXml.strWorkPath = strSheetPath
   clsSaveXml.srXMLName = ActiveSHeet.Name
   lRslt = clsSaveXml.SaveMain()
   '出力完了したら元のシートに戻す
   Worksheets("SetData").Activate
   '毎回解放処理をする
   If Not clsSaveXml Is Nothing Then Set clsSaveXml = Nothing
  End If
  iRowCnt = iRowCnt + 1
 Next
 Application.ScreenUpdating = True
 '終了メッセージ
End Sub 

　SetDataにあるシートリストから、チェックが入っているものを出力してます。
　ちなみに、シートリストは以下のように作成してます。

Sub <関数名>()
 Dim iChkBoxCnt As Integer
 iChkBoxCnt = 0
 Range("H4:I1000").CrearContents
 Set c = Cell(4, "I")
 For i = ActivateSheet.Index + 1 To Sheets.Count
  Set s = ActiveWorkBook.Sheets(i)
  If s.Visible = True Then
   ActieSheet.Hyperlinks.Add c, "", "'" & s.Name & "'" & "!A1", "", s.Name
   iChkBoxCnt = iChkBoxCnt + 1
  End If
  Set c = c.Offset(1, 0)
 Next
 Range("I4:I" & i).Sort, Key1:=xlAscendng, Header:=xlGuess, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin

 'チェックボックス設置
 Dim myChk As Object
 Dim StartCell As Range
 Set StartCell = Range("H4")
 For i = 0 To iChkBoxcnt -1
  With StartCell.Offset(i)
   Set myChk = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, DIsplayAsIcon:=False, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  End With
  With myChk
   .LinkedCell = StartCell.Offset(i, 0).Address
   .Object.Caption = ""
   .Object.Value = False
  End With
 Next
End Sub

Class内処理

　SaveMain()を呼んで、出力処理を実行していく形となります。

Public Function SaveMain() As Long
 SaveMain = 255
 '初期設定
 If Set_ALLCRGrid() = False Then
  Exit Function
 End If
 'XMLドキュメントおまじない部分設定
 Call Set_CreateXMLDoc
 'ルート要素設定
 Call Set_XMLDataToRoot
 'ルート配下項目取得
 Dim iRowCnt, iAryCnt As Integer
 '現在の列位置を補完
 Dim strTmpCol As String
 '結合判定要変数定義
 Dim bMergeRow As Boolean
 Dim iMergeCnt As Integer
 Dim strTmpTagText As String
 bMergeRow = False
 iMergeCnt = 0

 'カウンタに格納
 iRowCnt = iStartPoint
 'データ開始地点から終端行までデータ取得を実施する
 DO
  iAryCnt = 1
  '1つ目は基本的に存在する。データ有無で隣のCellをチェック
  strTmpTagText = ActiveSheet.Range(CellTNV(iAryCnt).TAgCol & iRowCnt).Text
  If Len(strTmpTagText) <> 0 Then
   '1つ目の前はRootとなる
   CellTNV(iAryCnt).BeforeCol = CellTNV(iAryCnt -1).TagCol
  Else
   'タグ名２つ目以降の処理（Root以外）
   For iAryCnt = 1 TO UBound(CellTNV)
    strTmpTagText = ActiveSheet.Range(CellTNV(iAryCnt).TagCol & iRowCnt).Text
    If Len(strTmpTagText) <> 0 Then
     CellTNV(iAryCnt).BeforeCol = CellTNV(iAryCnt -1).TagCol
     Exit For
    End If
   Next
  End If
  'コメント行はそのまま出力し１つ下に進める。
　'データ行はタグのデータを採取し次のデータへ進める（結合しているから次のRowまで増やす）
  If strTmpTagText = CEL_COMMENT Then
   Call Set_XMLComment(iAryCnt, iRowCnt)
   iRowCnt = iRowCnt + 1
  Else
   Dim iNextRow As Integer
   Call Set_XMLDataForCell(iAryCnt, iRowCnt, strTmpTag, iNextRow)
   iRowCnt = iRowCnt + iNextRow
  End If
 Loop While iRowCnt < iEndPoint

 'XML出力を行う
 Dim strXMLFilePath As String
 strXMLFilePath = strWorkPath & "¥" & strXMLName
 XMLMngr.reader.parse XMLMngr.xmlDocument
 XMLMngr.xmlOutDocument.LoadXML(XMLMngr.writer.output)
 Dim testDOM As IXMLDOMProcessingInstruction
 Set testDOM = XMLMngr.xmlOutDocument.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8"")
Call XMLMngr.xmlOutDocument.replaceChild(testDOM, XMLMngr.xmlOutDocument.irstChild)

 XMLMngr.xmlOutDocument.Save(strXMLFilePath)
 ActiveSheet.Range("A1").Select
 '変数を全て初期化
 Erase CellTNV
 iEndPoint = 0
 iStartPoint = 0
 strTmpAttr = ""
 strTmpMergeCol = ""
 strLpBeforeCol = ""
 strLpCol = ""
 Erase CellTNV()
 SaveMain = 0

End Function

　
　頭から１行ずつ書き出していく形となります。
　なお、現状の使用ではUTF-16で出力するようですね。
　内部で使用しているXMLは、UTF-8作成されているため、
　最後に文字を置換してます。
　また、外部変数などは以下の通りとなります。

'定数
Const CEL_EOF As String = "ENDOFFILE"
Const CEL_ROOTTDATA As String = "RootDatas"
Const CEL_TAGATA1 AS String = "TagDatas01"
Const CEL_TAGATA2 AS String = "TagDatas02"
Const CEL_TAGATA3 AS String = "TagDatas03"
Const CEL_TAGATA4 AS String = "TagDatas04"
Const CEL_TAGATA5 AS String = "TagDatas05"
Const CEL_TAGATA6 AS String = "TagDatas06"
Const CEL_TAGATA7 AS String = "TagDatas07"
Const CEL_TAGATA8 AS String = "TagDatas08"
Const CEL_ATTRIBUT As String = "AttributeDatas"
Const CEL_VALUES As String = "VAlues"
Const CEL_COMMENT As String = "comment"
'なし
Const INPUT_CELL_NONE As Integer = 0
'値のみ
Const INPUT_CELL_VALUE As Integer = 1
'属性＋値
Const INPUT_CELL_AANDV As Integer = 2

'構造体
Private Type CellRootPoint
 'ルート位置（カラムと列）
 RootCol As String
 RootRow As String
End Type

'タグ・属性値・値用構造体
Private Type CellTNVPoint
 TagCol As String
 TagRow As String
 NodeCOl As String
 NodeRow As String
 ValCol As String
 ValRow As String
 BeforeCol As String '前の列位置
 xmlTag Data As IXMLDOMNode '要素名
End Type

'XML用変数構造体
Private Type XMLManager
 'XMLドキュメント用と出力用
 xmlDocument As MSXML2.DOMDocument60
 xmlOutDocument As MSXML2.DOMDocument60
 'XML宣言
 xmlPI As IXMLDOMProcessingInstruction
 'XMLルート要素ノードと共通ノード
 xmlroot As IXMLDOMNode
 node As IXMLDOMNode
 '属性設定用
 attributes As MSXML2.IXMLDOMAttribute
 'XML出力よう
 reader As New SAXXMLReader60
 writer As New MXXMLWriter60
End Type

'外部変数宣言(Private)
'ルート・タグ用
Private CellRoot As CellRootPoint
Private CellTNV() As CellTNVPoint
'XML管理用変数
Private XMLMngr As XMLManager
'最終行・開始行取得
Private iEndPoint, iStartPoint As Integer
'属性値・値・結合時のColumn設定よう
Private strTmpAttr, strTmpVal, strTmpMergeCol As String
'値取得時、前からむと現在カラム格納よう
Private strLpBeforeCol, strLpCol As String

'外部変数宣言(Public)
'XML名・出力位置
Public strXMLName As String
Public strWorkPath As String
'BUILDVersion
Public strBldver As String

　定数はいいとして、構造体、作る必要あったのだろうか・・・。
　(構造体の方が見易かっただけだったと思いますが・・・)

　そういえば冒頭に記載してませんが、フォーマットが決まっているので
　それようにガッツリ組んでます。
　– ルート名・タグ名（８列）・属性値・値

それぞれの処理

　SaveMain関数ないで行っているそれぞれの関数処理を記載します。

　1)Set_ALLCRGrid 関数
　　罫線内のデータについて採取情報を設定します。
　　CELL_TAGDATA* は、タグ名のCell自体に名前入れており、
　　それらをチェックなどを行うためとなります。
　　開始位置と終了位置の設定、というところだったかと・・・。

'各位置のCol,Row設定関数
Private Function Set_ALLCRGrid() As Boolean
 Set_ALLCRGrid = False
 'Col,Row 一時格納変数
 Dim iTmpRow As Integer
 Dim strTmpCol As String

 Dim arystrConst As Variant
 Dim i, iCellCnt As Integer
 arystrConst = Array(CEL_TAGDATA1,CEL_TAGDATA2,CEL_TAGDATA3,CEL_TAGDATA4, _
                     CEL_TAGDATA5,CEL_TAGDATA6,CEL_TAGDATA7,CEL_TAGDATA8)

 'ルートタグ設定
 ReDim CellTNV(0)
 Call Set_StartPointOfColAndRow(CEL_ROOTDATA, CellTNV(0).TagRow, CellTNV(0).TagCol)
 '属性値と値の位置取得(ルートタグに格納)
 Call Set_StartPointOfColAndRow(CEL_ATTRIBUT, CellTNV(0).NodeRow, CellTNV(0).NodeCol)
 Call Set_StartPointOfColAndRow(CEL_VALUES, CellTNV(0).ValRow, CellTNV(0).ValCol) 
 '初期位置設定
 iStartPoint = CellTNV(0).TagRow
 '最終行取得
 iEndPoint = ActiveSheet.Range(CEL_EOF).Row -1
 '---ルート配下の値を取得---
 For i = 0 To UBound(arystrConst)
  iCellCnt = i +1
  '行列取得
  Call Set_StartPointOfColAndRow(arystrConst(i), iTmpRow, strTmpCol)
  If Chk_Contain(strTmpCol & iTmpRow & ":" & strTmpCol & iEndPoint) = True Then
   ReDim Preserve CellTNV(iCellCnt)
   '値の設定
   CellTNV(iCellCnt).TagRow = iTmpRow
   CellTNV(iCellCnt).TagCol = strTmpCol
  Else
   'データ取れてない場合などの処理
   If i = 0 Then
    Set_ALLCRGrid = False
    Eit Function
   Else
    Exit For
   End If
  End If
 Next
 '使用変数初期化と問題ないのでTrue設定
 iTmpRow = 0
 strTMpCol = ""
 Set_ALLCRGrid = True
End Function

　中で出てきた　Set_StartPointOfColAndRow関数は以下の通りとなる。
　RowとCol・・・A1 となっているところ、Aと1に分割して返却する。

'ARG1：取得位置名
'ARG2：列の値（返却）
'ARG3：行の値（返却）
Private Sub Set_StartPointOfColAndRow(ByVal strArgCellname As String, _
                                   ByRef iArgRow As Integer, _
                                   ByRef strArgCol As String)

 '取得したRow + 2がスタート位置
 'Cellに名前入れているが、間に表題があるため
 iArgRow = ActiveSheet.Range(strArgCellName).Row + 2
 'Col設定
 Dim strAddress As String
 strAddress = ActiveSheet.Range(strArgCellName).Address(False, False)
 strArgCol = Left(strAddress, Len(strAddress) - Len(CStr(iArgRow)))
End Sub

　2)Set_CreateXMLDoc 関数
　　XML作成するための文言？宣言が必要になるのでそれらの設定を行うための関数です。
　　なお、公式かどこかからのコピペなので、細かい処理内容は不明!!

Private Sub Set_CreateXMLDoc()
 XMLMngr.writer.indent = True
 XMLMngr.writer.standalone = True
 XMLMngr.writer.Encoding = "Shift_jis" '無視されてUTF-16になる
 Set XMLMngr.reader.contentHandler = XMLMngr.writer
 'おまじない文書
 Call XMLMngr.reader.putProperty("http://xml.org.sax/properties/lexical-handler", XMLMngr.writer)
 '--- XML 作成　---
 Set XMLMngr.xmlDocument = New MSXML2.DOMDocument60
 Set XMLMngr.xmlOutDocument = New MSXML2.DOMXosument60
 'xml 宣言部分作成
 Set XMLMngr.xmlPI = XMLMngr.xmlDocument.appendChild(XMLMngr.xmlDocument.createProCessingInstruction("xml", "version=""1.0"" encoding=""UTF-8"""))
End Sub

　3)Set_XMLDataToRoot 関数
　　Root部分の作成です。
　　中で使用する関数も記載します。

Private Sub Set_XMLDataToRoot()
 Dim iTmpRow As Integer
 Dim bMergeRow As Boolean '結合判定
 Dim i As Integer
 Dim aryNodeAndVal() As String
 Dim iMergeCnt As Integer
 '結合列確認
 iMergeCnt = ActiveSheet.Range(CellTNV(0).TagCol & CellTNV(0).TagRow).MergeArea.Rows.Count
 iTmpRow = CellTNV(0).TagRow

 ReDim aryNodeAndVal((iMergeCnt -1), 2)
 '配列に格納
 For i = 0 TO UBound(aryNodeAndVal, 1)
  '値と属性取得
　Get_AttrDataAdnValuesData(iTmpRow)
  aryNodeAndVAl(i, 0) = strTmpAttr
  aruNodeAndVal(i, 1) = strTmpVal
  aryNodeAndVal(i, 2) = CStr(Check_InputCell_ToAttrAndVALUE(strTmpAttr, strTmpVal)
  iTmpRow = iTmpRow + 1
 Next

 Dim bAllVal As Boolean
 '配列並び替え
 If UBound(aryNodeAndVal) >= 1 Then
  If CInt(aryNodeAndVal(0,2)) = INPUT_CELL_VALUE Then
   aryNodeAndVAl = Set_ArySort(aryNodeAndVal, bAllVal)
  End If
 End If

 Dim xmlAttr As Object
 Set XMLMngr.xmlroot = XMLMngr.xmlDocument.appendChild(XMLMngr.xmlDocument.createElement(ActiveSheet.Range(CellTNV(0).TagCol & CellTNV(0).TagRow).Text))
 'データ設定
 For i = 0 To UBound(aryNodeAndVal)
  Select Case CInt(aryNodeAndval(i, 2))
   Case INPUT_CELL_NONE
   Case INPUT_CELL_VALUE
    '値のみ
    Set XMLMngr.xmlroot = XMLMngr.xmlroot.appendChild(XMLMngr.xmlDocument.createTextNode(aryNodeAndVAl(i, 1)))
  Case INPUT_CELL_AANDV
   '属性値
   Set xmlAttr = XMLMngr.xmlroot.Attributes.setNamedItem(XMLMngr.xmlDocument.createAttribute(aryNodeAndVAl(i, 0)))
  Case Else
 End Select
 Next
 'ルート要素設定後１行下げる
 iStartPoint = iStartPoint + iMergeCnt
Exit Sub

'--- 属性値と値取得関数
Private Sub Get_AttrDataAndValuesData(iTmpRow)
 strTmpAttr = ActiveSheet.Range(CellTNV(0).NodeCol & iTargetRow).Text
 strTmpVal = ActiveSheet.Range(CellTNV(0).ValCol & iTargetRow).Text
End Sub

'--- 対象列状態取得関数
'渡された引数などより、セルがどういうものかチェックして返却する
Private Function Check_inputCell_ToAttrAndVALUE(Optional Byval strArgAttr As String = "", Optional ByVal strArgVal As String = "") As Integer

 '引数がない場合は結合なし、ある場合は結合あり
 If Len(strArgAttr) = 0 And Len(strArgVal) = 0 Then
  If Len(strTmpAttr) = 0 And Len(strTmpVal) = 0 Then
   Check_inputCell_ToAttrAndVALUE = INPUT_CELL_NONE
  ElseIf Len(strTmpAttr) = 0 And Len(strTmpVal) <> 0 Then
   Check_inputCell_ToAttrAndVALUE = INPUT_CELL_VALUE
  Else
   Check_inputCell_ToAttrAndVALUE = INPUT_CELL_VAANDV
  End If
 Else
  If Len(strArgAttr) = 0 And Len(strArgVal) = 0 Then
   Check_inputCell_ToAttrAndVALUE = INPUT_CELL_NONE
  ElseIf Len(strTmpAttr) = 0 And Len(strTmpVal) <> 0 Then
   Check_inputCell_ToAttrAndVALUE = INPUT_CELL_VALUE
  Else
   Check_inputCell_ToAttrAndVALUE = INPUT_CELL_VAANDV
  End If
 End If
End Function

'--- 配列ソート関数
Private Function Set_ArySort(ByRef strArgData() As String, ByRef bAllVal As Boolean) As String()

 DIm iCnt As Integer
 Dim sTmpAtr,sTmpVal,sInType As String
 bAllVal = False
 '配列ないを入れ替える
 For iCnt = 0 To Ubound(strArgData) -1
  sTmpAtr = strArgData(iCnt, 0)
  sTmpVal = strArgData(iCnt, 1)
  sInType = strArgData(iCnt, 2)
  strArgData(iCnt, 0) =  strArgData((iCnt + 1), 0)
  strArgData(iCnt, 1) =  strArgData((iCnt + 1), 1)
  strArgData(iCnt, 2) =  strArgData((iCnt + 1), 2)
  strArgData((iCnt + 1), 0) = sTmpAtr
  strArgData((iCnt + 2), 0) = sTmpVal
  strArgData((iCnt + 3), 0) = sInType
 Next
 '値耳かチェックし、返却する値を設定
 For iCnt = 0 To UBound(strArgData)
  If strArgData(iCnt, 0) = "" And strArgData(iCnt, 1) <> "" Then
   bAllVal = True
  Else
   bAllVal = False
   Exit For
  End If
 Next
 Set_ArySort = strArgData
End Function

　4)XML Data 採取
　　Main関数内のループ処理で、書き出しデータを変数内に出力しているけど、
　　コメントかデータかで分岐して出している。
　　なお、コメントも入れているが、機能としては使用していない。
　　※処理だけ入れているが、別紙添付資料としてはコメントまでは不要となるため

'--- XMLデータ書込関数（コメント）
Private Sub Set_XMLComment(ByVal iTargetAry As Integer, ByVal iNowRow As Integer)

 Dim xmlParent As IXMLDOMNode
 Dim newComment
 Cal Get_AttrDataAndValuesData(iNowRow)
 '0の場合タグ１列目のルートノード配下、０以外は配列に格納されているノード
 If iTargetAry = 0 Then
  Set xmlParent = XMLMngr.xmlroot
 Else
  Set xmlParent = CellTNV(itargetAry -1).xmlTagData
 End If
 Set newComment = XMLMngr.xmlDocument.createComment(strTmpVal)
 xmlParent.appendChild(newComment)
 '0の場合はルートノード配下でルートに格納、０以外は配列に格納
 If iTargetAry = 0 Then
  Set XMLmngr.xmlroot = xmlParent
 Else
  Set CellTNV(iTargetAry -1).xmlTagData = xmlParent
 End If
End Sub

'--- XMLデータ書込関数
Private Sub Set_XMLDataForCell(ByVal iTargetAry As Integer, _
                               ByVal iNowRow As integer, _
                               ByVal strArgTagText As String, _
                               ByRef iNextRow As Integer)
 Dim iMergeCnt, i As Integer
 '結合数取得
 iMergeCnt = ActiveSheet.Range(CellTNV(iTargetAry).TagCol & iNowRow).MergeArea.Rows.Count

 iNextRow = iMergeCnt
 Dim xmlParent As IXMLDomNode
 Dim xmlChild As IXMLDOMNode

 If iTargetAry = 1 Then
  Set xmlParent = XMLMngr.xmlroot
 Else
  Set xmlParent = CellTNV(iTargetAry).xmlTagData

  Dim aryNodeAndVAl() As String
  ReDim aryNodeAndVal(iMergeCnt -1, 2)
  '配列に属性・属性値格納
  For i=0 To UBound(aryNodeAndVal, 1)
   Call Set_AttrDataAbdVakesData(iNowRow)
   aryNodeAndVal(i, 0) = strTmpAttr
   aryNodeAndVal(i, 1) = strTmpVal
   aryNodeAndVal(i, 2) = CStr(Check_InputCell_ToAttrVALUE(strTmpAttr, strTmpVal))
   iNowRow = iNowRow + 1
  Next
  '先頭データが値の場合のみ配列並び替え
  Dim bAllVal As Boolean
  If UBound(aryNodeAndVal) >= 1 Then
   If CInt(aryNodeAndVal(0, 2)) = INPUT_CELL_VALUE Then
    aryNodeAndVal = Set_ArySort(aryNodeAndVal, bAlAVal)
   End If
  End If

  '子データの処理
  Dim xmlAttr As Object
  Set xmlChild = xmlParent.appendChild(XMKMngr.xmlDocument.createElement(strArgTagText))

  For i = 0 To UBound(aryNodeAndVal)
   Select Case CInt(aryNodeAndVal(i, 2))
    Case INPUT_CELL_NONE
    Case INPUT_CELL_VALUE
     If bAllVal = True And i <> 0 THen
      Set xmlChild = xmlParent.appendChild(XMLMngr.xmlDocument.createElement(strArgTagText))
      Set xmlChild = xmlChild.appendChild(XMLMngr.xmlDocument.createTextNode(aryNodeAndVal(i, 1)))
     Else
      Set xmlChild = xmlChild.appendChild(XMLMngr.xmlDocument.createTextNode(aryNodeAndVal(i, 1)))
     End If
    Case INPUT_CELL_AANDV
     Set mlAttr = xmlChild.Attributes.setNamedItem(XMLMngr.xmlDocument.createAttribute(aryNodeAndVal(i, 0)))
    Case Else
   End Select
  Next
  'XMLオブジェクト設定（親）
  If Not xmlParet Is Nothing Then
   If iTargetAry = 1 Then
    Set XMLMngr.xmlroot = xmlParent
   Else
    Set CellTNV(iTargetAry - 1).xmlTagData = xmlParent
   End If
  'XMLオブジェクト設定（子）
  If Not xmlChild Is Nothing Then
   Set CellTNV(iTargetAry).xmlTagData = xmlChild
  End If
End Sub

　5)その他関数
　　Set_ALLCRGrid 関数内で１つやってたのでそれを記載します。
　　１つ目は値が入っているかのチェック。
　　もう１つはデストラクタです。

'--- チェック関数
Private Function Chk_Contain(ByVal strTagRange As String) As Boolean
 Dim iTmpCnt As Integer
 iTmpCnt = Application.WorksheetFunction.CountA(strTagRange)
 If iTmpCnt = 0 Then
  Chk_Contain = False
 Else
  Chk_Contain = True
 End If
End Function

'--- デストラクタ
Public Sub Class_Terminate()
 XMLMngr内のオブジェクトを　If Is Nothing で判定して、
 使用している場合のみNothingを設定するようにする。
End Sub

まとめ

冒頭にも記載している通り、XMLであってもモジュール扱いなので修正がないようにするため、
インデントが元から揃えられているようには出来ないため、本プログラムは使用しないようになりました。

また、作成したのが２〜３年前なので、どういう処理させていたか忘れてたりもします。
（といっても、前回も書きましたが、今時Excelでやる人いないでしょ。）