Tableauデータソース解析マクロ（パラメータ）

Option Explicit

Sub AnalyzeTableauParameters()
    Dim xmlDoc As Object
    Dim xmlFilePath As String
    Dim datasourcesNode As Object
    Dim datasourceNode As Object
    Dim datasourceName As String
    Dim ws As Worksheet
    Dim rowNum As Long

    ' ファイル選択ダイアログを表示
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Tableauワークブックファイル(.twb)を選択してください"
        .Filters.Clear
        .Filters.Add "Tableauワークブック", "*.twb"
        .Filters.Add "XMLファイル", "*.xml"
        .AllowMultiSelect = False

        If .Show = -1 Then
            xmlFilePath = .SelectedItems(1)
        Else
            MsgBox "ファイルが選択されませんでした。", vbExclamation
            Exit Sub
        End If
    End With

    ' XML DOMオブジェクトを作成
    Set xmlDoc = CreateObject("MSXML2.DOMDocument.6.0")

    ' XML設定
    xmlDoc.async = False
    xmlDoc.validateOnParse = False
    xmlDoc.resolveExternals = False
    xmlDoc.preserveWhiteSpace = True

    ' 結果出力用のワークシートを作成または取得
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("パラメータ解析結果")
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add
        ws.Name = "パラメータ解析結果"
    Else
        ws.Cells.Clear
    End If
    On Error GoTo 0

    ' ヘッダーを設定
    SetupHeaders ws
    rowNum = 2

    ' XMLファイルを読み込み
    If xmlDoc.Load(xmlFilePath) Then
        Debug.Print "XMLファイルの読み込みに成功しました: " & xmlFilePath

        ' <datasources>要素を取得
        Set datasourcesNode = xmlDoc.getElementsByTagName("datasources")(0)

        If Not datasourcesNode Is Nothing Then
            ' <datasource>要素分ループ
            For Each datasourceNode In datasourcesNode.ChildNodes
                If datasourceNode.NodeType = 1 And datasourceNode.nodeName = "datasource" Then
                    datasourceName = GetAttributeValue(datasourceNode, "name")

                    ' Parametersデータソースのみ処理
                    If datasourceName = "Parameters" Then
                        rowNum = ProcessParametersNode(datasourceNode, ws, rowNum)
                    End If
                End If
            Next datasourceNode
        End If

        ' 列幅を自動調整
        ws.Columns("A:J").AutoFit

        MsgBox "パラメータ解析が完了しました。", vbInformation

    Else
        MsgBox "XMLファイルの読み込みに失敗しました: " & xmlFilePath & vbCrLf & _
               "エラー: " & xmlDoc.parseError.reason, vbCritical
    End If

    ' オブジェクトを解放
    Set datasourceNode = Nothing
    Set datasourcesNode = Nothing
    Set xmlDoc = Nothing

End Sub

' ヘッダーを設定
Sub SetupHeaders(ws As Worksheet)
    With ws
        .Range("A1").value = "名前"
        .Range("B1").value = "表示名"
        .Range("C1").value = "データ型"
        .Range("D1").value = "現在の値"
        .Range("E1").value = "ワークブックが開いているときの値"
        .Range("F1").value = "表示形式"
        .Range("G1").value = "許容値"
        .Range("H1").value = "ワークブックが開いている場合"
        .Range("I1").value = "リスト内容"
        .Range("J1").value = "範囲設定"

        ' ヘッダー書式設定
        .Range("A1:J1").Font.Bold = True
        .Range("A1:J1").Interior.ColorIndex = 15
        .Range("A1:J1").Borders.LineStyle = xlContinuous
    End With
End Sub

' Parametersノードを処理
Function ProcessParametersNode(datasourceNode As Object, ws As Worksheet, startRow As Long) As Long
    Dim columnNode As Object
    Dim rowNum As Long

    rowNum = startRow

    ' column要素をループ
    For Each columnNode In datasourceNode.ChildNodes
        If columnNode.NodeType = 1 And columnNode.nodeName = "column" Then
            ' パラメータ情報を取得して行に出力
            ProcessParameterColumn columnNode, ws, rowNum
            rowNum = rowNum + 1
        End If
    Next columnNode

    ProcessParametersNode = rowNum
End Function

' 個別のパラメータ列を処理
Sub ProcessParameterColumn(columnNode As Object, ws As Worksheet, rowNum As Long)
    Dim paramName As String
    Dim paramCaption As String
    Dim paramDataType As String
    Dim paramValue As String
    Dim defaultValueField As String
    Dim paramFormat As String
    Dim paramDomainType As String
    Dim sourceField As String
    Dim listContent As String
    Dim rangeContent As String

    ' 基本属性を取得
    paramName = GetAttributeValue(columnNode, "name")
    paramCaption = GetAttributeValue(columnNode, "caption")
    paramDataType = TranslateDataType(GetAttributeValue(columnNode, "datatype"))

    ' 現在の値を取得
    paramValue = GetAttributeValue(columnNode, "value")

    ' ワークブックが開いているときの値を取得
    defaultValueField = GetAttributeValue(columnNode, "default-value-field")

    ' 表示形式を取得
    paramFormat = GetAttributeValue(columnNode, "default-format")

    ' 許容値を取得
    paramDomainType = TranslateDomainType(GetAttributeValue(columnNode, "param-domain-type"))

    ' ワークブックが開いている場合を取得
    sourceField = GetAttributeValue(columnNode, "source-field")

    ' リスト内容を取得
    If GetAttributeValue(columnNode, "param-domain-type") = "list" Then
        listContent = GetListContent(columnNode)
    Else
        listContent = ""
    End If

    ' 範囲設定を取得
    If GetAttributeValue(columnNode, "param-domain-type") = "range" And sourceField = "" Then
        rangeContent = GetRangeContent(columnNode)
    Else
        rangeContent = ""
    End If

    ' ワークシートに出力
    With ws
        .Cells(rowNum, 1).value = paramName
        .Cells(rowNum, 2).value = paramCaption
        .Cells(rowNum, 3).value = paramDataType
        .Cells(rowNum, 4).value = paramValue
        .Cells(rowNum, 5).value = defaultValueField
        .Cells(rowNum, 6).value = paramFormat
        .Cells(rowNum, 7).value = paramDomainType
        .Cells(rowNum, 8).value = sourceField
        .Cells(rowNum, 9).value = listContent
        .Cells(rowNum, 10).value = rangeContent

        ' 枠線を設定
        .Range(.Cells(rowNum, 1), .Cells(rowNum, 10)).Borders.LineStyle = xlContinuous
    End With
End Sub

' データ型を読み替え
Function TranslateDataType(dataType As String) As String
    Select Case dataType
        Case "real": TranslateDataType = "浮動小数点数"
        Case "integer": TranslateDataType = "整数"
        Case "string": TranslateDataType = "文字列"
        Case "boolean": TranslateDataType = "ブール値"
        Case "date": TranslateDataType = "日付"
        Case "datetime": TranslateDataType = "日付時刻"
        Case "spatial": TranslateDataType = "空間"
        Case Else: TranslateDataType = dataType
    End Select
End Function

' 許容値を読み替え
Function TranslateDomainType(domainType As String) As String
    Select Case domainType
        Case "any": TranslateDomainType = "すべて"
        Case "list": TranslateDomainType = "リスト"
        Case "range": TranslateDomainType = "範囲"
        Case Else: TranslateDomainType = domainType
    End Select
End Function


' 属性値を安全に取得
Function GetAttributeValue(node As Object, attributeName As String) As String
    Dim attrValue As Variant

    On Error Resume Next
    attrValue = node.getAttribute(attributeName)
    On Error GoTo 0

    If IsNull(attrValue) Then
        GetAttributeValue = ""
    Else
        GetAttributeValue = CStr(attrValue)
    End If
End Function

' リスト内容を取得
Function GetListContent(columnNode As Object) As String
    Dim aliasesNode As Object
    Dim membersNode As Object
    Dim aliasNode As Object
    Dim memberNode As Object
    Dim result As String
    Dim key As String
    Dim value As String

    result = ""

    ' aliases要素を確認
    Set aliasesNode = columnNode.SelectSingleNode("aliases")
    If Not aliasesNode Is Nothing Then
        ' alias要素をループ
        For Each aliasNode In aliasesNode.SelectNodes("alias")
            key = GetAttributeValue(aliasNode, "key")
            value = GetAttributeValue(aliasNode, "value")
            If result <> "" Then result = result & ", "
            result = result & key & ":" & value
        Next aliasNode
    Else
        ' members要素を確認
        Set membersNode = columnNode.SelectSingleNode("members")
        If Not membersNode Is Nothing Then
            ' member要素をループ
            For Each memberNode In membersNode.SelectNodes("member")
                value = GetAttributeValue(memberNode, "value")
                If result <> "" Then result = result & ", "
                result = result & value
            Next memberNode
        End If
    End If

    GetListContent = result
End Function

' 範囲設定を取得
Function GetRangeContent(columnNode As Object) As String
    Dim rangeNode As Object
    Dim minValue As String
    Dim maxValue As String
    Dim result As String

    ' range要素を確認
    Set rangeNode = columnNode.SelectSingleNode("range")

    If Not rangeNode Is Nothing Then
        minValue = GetAttributeValue(rangeNode, "min")
        maxValue = GetAttributeValue(rangeNode, "max")

        If minValue <> "" And maxValue <> "" Then
            result = "最小値:" & minValue & ", 最大値:" & maxValue
        ElseIf minValue <> "" Then
            result = "最小値:" & minValue
        ElseIf maxValue <> "" Then
            result = "最大値:" & maxValue
        Else
            result = "指定なし"
        End If
    Else
        result = "指定なし"
    End If

    GetRangeContent = result
End Function