GDIplusCODE


☆入力規則生成用のデータ(Sheets("Sheet1"))
L1	L2	L3 	L4	L5
A	A1	A11	A111	A1111
A	A1	A11	A111	A1112
（以下略）

☆標準モジュール
'汎用化したので、コードは短くなっています。
'Microsoft XML V3.0に参照設定
Public oXMLDom As DOMDocument30
Public myColumnCount As Long

Public Sub setDOM()
  Dim i As Long, j As Long, k As Long
  Dim myXPath As String
  Dim targetRange As Range
  Dim buf As Variant
  Dim root As IXMLDOMElement
    
  Set oXMLDom = New DOMDocument30
  '初期設定
  settingDOM oXMLDom
  setInfo oXMLDom, "xml test"
  'ワークシートから絞り込み選択用リスト取得 Variant配列に収納
  Set targetRange = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion
  Set targetRange = Intersect(targetRange, targetRange.Offset(1, 0))
  buf = targetRange.Value
  Set root = oXMLDom.createElement("root")
  oXMLDom.appendChild root
  myColumnCount = UBound(buf, 1)
  
  For i = 1 To UBound(buf, 2)
    Call addElement(root, i, buf)
  Next i
'  Debug.Print oXMLDom.XML
End Sub
  
Sub addElement(root As IXMLDOMElement, level As Long, buf As Variant)
  Dim i As Long, j As Long
  Dim parentElement As IXMLDOMElement
  Dim newElement As IXMLDOMElement
  Dim myXPath As String
  Dim retNode As IXMLDOMNodeList
  
  For i = 1 To UBound(buf, 1)
    myXPath = "/" & root.nodeName
    For j = 1 To level - 1
      If level > 1 Then myXPath = myXPath & "/" & buf(i, j)
    Next j
    
    Set parentElement = root.SelectSingleNode(myXPath)
    Set retNode = root.SelectNodes(myXPath & "/" & buf(i, level))
    If retNode.Length = 0 Then
      Set newElement = oXMLDom.createElement(buf(i, level))
      parentElement.appendChild newElement
    End If
  Next i
End Sub

'MSXMLDOMの設定
Private Sub settingDOM(ByRef dom As DOMDocument30)
  With dom
    .async = False
    .validateOnParse = False
    .resolveExternals = False
    .preserveWhiteSpace = True
    .setProperty "SelectionLanguage", "XPath"
  End With
End Sub

'XMLのヘッダー？の部分を設定
Private Sub setInfo(ByRef dom As DOMDocument30, comment As String)
  Dim node As IXMLDOMNode
  
  Set node = dom.createProcessingInstruction("xml", "version=""1.0"" encoding=""Shift_JIS""")
  dom.appendChild node
  Set node = Nothing
  Set node = dom.createComment(comment)
  dom.appendChild node
  Set node = Nothing
End Sub

☆ワークシートモジュール
A→B→C→D→E列にWorksheet_SelectionChangeのイベントにより動的に入力規則を生成します
Private Sub Worksheet_SelectionChange(ByVal target As Range)
  Dim Dummy As Range

  If oXMLDom Is Nothing Then setDOM
  If target.Cells.Count > 1 Then Exit Sub
  If target.Column > myColumnCount Then Exit Sub
  If target.Column > 1 Then
    On Error Resume Next
    Set Dummy = Intersect(target.Offset(0, -1), target.Offset(0, -1).SpecialCells(xlCellTypeAllValidation))
    On Error GoTo 0
    If Dummy Is Nothing Then Exit Sub
  End If
  setValidation target
End Sub

Private Sub setValidation(target As Range)
  Dim i As Long, j As Long
  Dim myXPath As String
  Dim root As IXMLDOMElement
  Dim retNode As IXMLDOMNodeList
  Dim strValidation As String

  Set root = oXMLDom.DocumentElement
  
  On Error GoTo errorHandle
  If target.Column = 1 Then
    Set retNode = root.ChildNodes
  Else
    myXPath = "/" & root.nodeName
    For j = target.Column - 1 To 1 Step -1
      myXPath = myXPath & "/" & target.Offset(0, -1 * j)
    Next j
    Set retNode = root.SelectSingleNode(myXPath).ChildNodes
  End If
  If retNode Is Nothing Then Exit Sub
  For i = 0 To retNode.Length - 1
    If strValidation = "" Then
      strValidation = retNode(i).nodeName
    Else
      strValidation = strValidation & "," & retNode(i).nodeName
    End If
    setvalidationSub target, strValidation
  Next i
errorHandle:
End Sub

Private Sub setvalidationSub(target As Range, strValidation As String)
    With target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=strValidation
    End With
End Sub
動的な入力規則生成をMSXML DOMでやってみた Part2
