Go to Qiita Advent Calendar 2024 Top
LoginSignup
1
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@intoOhoRoom(tomohiro ono)

VBAでtwbファイルを解析する

Last updated at Posted at 2024-03-08

twbファイルはxml形式になっており、xmlを解析することで計算フィールドを取得できます。

１．標準モジュール

共通

共通パーツを作ってます。
VBA初心者で階層化プログラミング等も素人のため、関数の切り出し方が正しいのかわかりませんが・・

Option Explicit

' 第一引数がNULLでなければ第一引数そのまま、NULLの場合は第二引数を返す
Function IfNull(ByVal Value As Variant, ByVal NullValue As Variant) As Variant
    If IsNull(Value) Then
        IfNull = NullValue
    Else
        IfNull = Value
    End If
End Function

' 整数に四捨五入する
Function RoundInt(ByVal Value As Double) As Long
    RoundInt = Int(Value * 10 + 0.5) / 10
End Function


' ファイル名を取得
Function getFilePath() As String
    Dim WS As Worksheet
    Const SHEET_NAME As String = "入力画面"
    Const ROW_FilePath As Integer = 17 'B17セル
    Const COL_FilePath As Integer = 2 'B17セル
    Set WS = ThisWorkbook.Worksheets(SHEET_NAME)
    getFilePath = WS.Cells(ROW_FilePath, COL_FilePath).Value
End Function

' twbファイルからタグを指定してノードを取得
Function getXmlNode(ByVal TWBFilePath As String, ByVal tag As String) As IXMLDOMElement
    Dim DOM As DOMDocument60
    Dim XML As IXMLDOMElement
    Dim Node As IXMLDOMElement
    
    Set DOM = New DOMDocument60
    
    If DOM.Load(TWBFilePath) Then
        Set XML = DOM.DocumentElement
        Set Node = XML.SelectSingleNode(tag)
        If Not (Node Is Nothing) Then
            Set getXmlNode = Node
        End If
    End If
End Function

' 既存のデータを削除する
Sub DeleteData(ByVal SHEET_NAME As String)
    Const ROW_FormulaStart As Long = 2
    Dim WS As Worksheet
    Dim Row As Long
    Set WS = ThisWorkbook.Worksheets(SHEET_NAME)

    Row = WS.UsedRange.Rows.Count
    If Row >= ROW_FormulaStart Then
        WS.Range(WS.Rows(ROW_FormulaStart), WS.Rows(Row)).ClearContents
    End If
End Sub

' 正規表現で文字列置換
Function Regexp_Replace(ByVal str1 As String, ByVal str2 As String, ByVal str3 As String) As String
    Dim re
    Set re = CreateObject("VBScript.RegExp")
    
    ' 正規表現パターンをセット
    re.Pattern = str2
    
    ' 第一引数が置換対象の文字列、第二引数が置換文字列
    Regexp_Replace = re.Replace(str1, str3)
End Function

' 正規表現で文字列取得
Function Regexp_Execute(ByVal str1 As String, ByVal str2 As String) As String
    Dim re
    Dim mc As MatchCollection
    Set re = CreateObject("VBScript.RegExp")
    
    ' 正規表現パターンをセット
    re.Pattern = str2
    re.Global = True
    
    '
    Set mc = re.Execute(str1)
    Regexp_Execute = mc(0).SubMatches(0)
End Function

' 正規表現で文字列取得
Function Regexp_Execute_Num(ByVal str1 As String, ByVal str2 As String, ByVal int1 As Integer) As String
    Dim re
    Dim mc As MatchCollection
    Set re = CreateObject("VBScript.RegExp")
    
    ' 正規表現パターンをセット
    re.Pattern = str2
    re.Global = True
    
    '
    Set mc = re.Execute(str1)
    Regexp_Execute_Num = mc(int1).SubMatches(0)
End Function

' 拡張子を指定して、ファイルを取得する関数
Function SelectFilePath(ByVal ExtensionRole As String) As String
    
    Dim FSO As FileSystemObject
    Dim FilePath As String
    Dim SelectedFilePath As Variant
    
    Set FSO = New FileSystemObject
    
    Do Until FSO.FileExists(FilePath)
        SelectedFilePath = Application.GetOpenFilename(ExtensionRole)
        If SelectedFilePath = False Then Exit Function
        FilePath = SelectedFilePath
    Loop
    SelectFilePath = FilePath
End Function

処理_001入力画面

入力画面でファイルを選択し取得するためのコードです。

Option Explicit

' twbファイルを取得しセルに貼り付ける
Sub Twbファイル取得()
    
    Const SHEET_NAME As String = "入力画面"
    Const ExtensionRole As String = "全てのTableau ワークブック(*.twb;),*.twb;,Tableau ワークブック(*.twb),*.twb" ' 拡張子
    Const PrintedCell As String = "B17" ' B17セル
    Dim WS As Worksheet

    Set WS = ThisWorkbook.Worksheets(SHEET_NAME)
    
    ' Tableauファイルを取得する
    WS.Range(PrintedCell).Value = SelectFilePath(ExtensionRole)

End Sub

処理_002フィールド

フィールド、計算フィールドを取得するためのコードです。

' Option Explicit
' 変数の定義（モジュール内で使うもの）
Dim DataSources As Dictionary ' データソースのリストを格納
Dim Fields As Dictionary ' フィールドのリストを格納
Dim XmlNodes As IXMLDOMElement 'ファイルから必要部のXMLを格納

' 処理開始
Sub 処理_フィールド()
    Call Controller
End Sub


' コントローラー
Private Sub Controller()
    Set XmlNodes = getXmlNode(getFilePath(), "//datasources") ' XMLの取得
    Call SanitizeXML                                          ' XMLを解析する
    Set XmlNodes = Nothing
    
    ' datasource
    Call DeleteData("データソース")                           ' 既存のデータを削除する
    Call PrintDataSourceKeyValues

    ' フィールド
    Call DeleteData("フィールド")                             ' 既存のデータを削除する
    Call PrintFieldsData                                      ' Excelへ出力
    
    ' 初期化
    DataSources.RemoveAll
    Fields.RemoveAll

End Sub


' XMLを解析する
Private Sub SanitizeXML()

    ' データソース関連
    Dim DataSourceNode As IXMLDOMElement  ' datasourceタグを格納
    Dim DataSourceId As String            ' name属性
    Dim DataSource As Variant             ' caption属性

    ' フィールド関連
    Dim ColumnNode As IXMLDOMElement      ' columnタグを格納(カラムはフィールドのこと)
    Dim Id As String
    Dim FieldId As String                 ' name属性
    Dim FieldCaption As String            ' caption属性
    Dim FieldRole As String               ' role属性
    Dim FieldDataType As String           ' datatype属性

    ' フィールド関連（計算フィールド）
    Dim CalculationNode As IXMLDOMElement ' calculationタグを格納
    Dim FieldFormula As String            ' formula属性

    ' 格納先
    Dim Field As FieldClass               ' datasourceタグを格納

    Set DataSources = New Dictionary      ' datasourceタグを格納
    Set Fields = New Dictionary           ' datasourceタグを格納

    ' Datasource
    For Each DataSourceNode In XmlNodes.SelectNodes("datasource[@name!='']")
        DataSourceId = DataSourceNode.getAttribute("name")
        DataSource = DataSourceNode.getAttribute("caption")
        If IsNull(DataSource) Then
            DataSource = DataSourceId
        End If
        DataSources.Add DataSourceId, DataSource

        ' Column
        For Each ColumnNode In DataSourceNode.SelectNodes(".//column[@name!='']")
            ' FieldId
            FieldId = ColumnNode.getAttribute("name")

            ' FieldCaption
            If IsNull(ColumnNode.getAttribute("caption")) Then
                FieldCaption = Mid(FieldId, 2, Len(FieldId) - 2)
            Else: FieldCaption = ColumnNode.getAttribute("caption")
            End If

            ' Id
            Id = "[" & DataSourceId & "]." & FieldId

            ' Formula
            Set CalculationNode = ColumnNode.SelectSingleNode("calculation[@formula!='']")
            If Not (CalculationNode Is Nothing) Then
                FieldFormula = CalculationNode.getAttribute("formula")
            Else: FieldFormula = ""
            End If
            
            ' クラス格納
            If InStr(FieldId, "[") = 1 And FieldCaption <> "" Then
                Set Field = New FieldClass

                Field.Id = Id
                Field.FieldId = FieldId
                Field.FieldCaption = FieldCaption
                Field.DataSource = DataSource
                Field.FieldFormula = FieldFormula
                Field.FieldRole = ColumnNode.getAttribute("role")
                Field.FieldDataType = ColumnNode.getAttribute("datatype")
                Fields.Add Id, Field

            End If
        Next ColumnNode
    Next DataSourceNode
End Sub


' データソースをExcelへ出力
Private Sub PrintDataSourceKeyValues()
    
    Const TARGET_SHEET As String = "データソース" ' 出力先シートを指定
    Dim DataSource As Variant              ' caption属性
    Dim Row As Long: Row = 2
    Dim WS As Worksheet
    
    Set WS = ThisWorkbook.Worksheets(TARGET_SHEET)

    For Each DataSource In DataSources.Keys
        WS.Cells(Row, 1) = "[" & DataSource & "]"
        WS.Cells(Row, 2) = DataSources.Item(DataSource)
        Row = Row + 1
    Next DataSource
End Sub


' フィールドをExcelへ出力
Private Sub PrintFieldsData()
    
    Const TARGET_SHEET As String = "フィールド" ' 出力先シートを指定
    Dim WS As Worksheet
    Dim Row As Long: Row = 2
    Dim DataSourceKey As Variant
    Dim FieldsKey As Variant
    Dim DataSourceId As String
    Dim DataSource As String
    Dim FieldFormula As String
    Dim Field As FieldClass
    
    Set WS = ThisWorkbook.Worksheets(TARGET_SHEET)
    
    ' datasourceごとに順次処理
    For Each DataSourceKey In DataSources.Keys
        
        DataSourceId = DataSourceKey
        DataSource = DataSources.Item(DataSourceId)
        
        ' 数式を順次処理
        For Each FieldsKey In Fields.Keys
            Set Field = Fields.Item(FieldsKey)
            If Field.DataSource = DataSource Then
                
                ' 出力
                WS.Cells(Row, 1) = Field.Id
                WS.Cells(Row, 2) = Field.DataSource
                WS.Cells(Row, 3) = getFieldType(Field.FieldFormula, DataSourceId)
                WS.Cells(Row, 4) = Field.FieldCaption
                WS.Cells(Row, 5) = getFieldFormula(Field.FieldFormula, DataSourceId)  ' , Field.DataSource
                WS.Cells(Row, 6) = Field.FieldRole
                WS.Cells(Row, 7) = Field.FieldDataType

                Row = Row + 1
            End If
        Next FieldsKey
    Next DataSourceKey
End Sub


' 計算フィールドの内部の置換する
Private Function getFieldFormula(ByVal FieldFormula_primary As String, ByVal DataSource_primary As String) As String
    Dim X As Variant
    Dim X2 As Variant
    Dim T As Variant
    Dim FieldFormula As Variant
    FieldFormula = FieldFormula_primary
    For Each X In Fields.Keys
        X2 = Application.WorksheetFunction.Substitute(X, "[" & DataSource_primary & "].", "")
        T = Fields.Item(X).FieldCaption
        T = "[" & T & "]"
        ' Formula内のXをTに置換する
        FieldFormula = Application.WorksheetFunction.Substitute(FieldFormula, X2, T)
    Next X
    getFieldFormula = FieldFormula
End Function


' 計算フィールドの内部の置換する
Private Function getFieldType(ByVal FieldFormula As String, ByVal DataSource As String) As String
    
    If DataSource = "Parameters" Then
        getFieldType = "パラメータ"
    ElseIf FieldFormula = "" Then
        getFieldType = "ローデータ"
    ElseIf FieldFormula <> "" Then
        getFieldType = "計算フィールド"
    End If

End Function

処理_003シートフィールド

ワークシート内にあるフィールドをリスト化します。
フィルターやどのようなマークで使用されているかも判断できます。
現状だと、行列やメジャーネームで指定するフィールドは取得できません。

Option Explicit
' 変数の定義（モジュール内で使うもの）
Dim WorkSheetFields As Dictionary ' フィールドのリストを格納
Dim Fields As Dictionary ' フィールドのリストを格納
Dim DataSources As Dictionary ' フィールドのリストを格納

Dim XmlNodes As IXMLDOMElement 'ファイルから必要部のXMLを格納

Sub 処理_シート_フィールド()
    Call Controller
End Sub

' コントローラー
Private Sub Controller()
    Set XmlNodes = getXmlNode(getFilePath(), "//worksheets") ' XMLの取得
 
    Call getFields ' Classを取得
    Call getDataSouces ' Classを取得
    Call SanitizeXML ' XMLを解析する
    
    Const TARGET_SHEET As String = "ワークシートフィールド" ' 出力先シートを指定
    Call DeleteData(TARGET_SHEET) ' 既存のデータを削除する
    Call PrintFieldsData ' Excelへ出力
End Sub

' XMLを解析する
Private Sub SanitizeXML()

    ' ワークシート関連（tableau）
    Dim WorkSheetNode As IXMLDOMElement
    Dim MarkNode As IXMLDOMElement
    Dim WorkSheetName As String

    Set WorkSheetFields = New Dictionary

    ' worksheet
    For Each WorkSheetNode In XmlNodes.SelectNodes("worksheet[@name!='']")
        WorkSheetName = WorkSheetNode.getAttribute("name")
        
        ' フィルター取得
        Call SanitizeXMLMarkNode(WorkSheetNode, WorkSheetName, ".//table/view/filter[@column!='']", "フィルター")
        
        ' フィルターの値
        Call SanitizeXMLMarkNodeFilterValue(WorkSheetNode, WorkSheetName, ".//table/view/filter/groupfilter/groupfilter[@level='[:Measure Names]']", "メジャーネーム")

        ' マーク
        For Each MarkNode In WorkSheetNode.SelectNodes(".//table/panes/pane/encodings")
            Call SanitizeXMLMarkNode(MarkNode, WorkSheetName, ".//color[@column!='']", "色")  ' 色取得
            Call SanitizeXMLMarkNode(MarkNode, WorkSheetName, ".//size[@column!='']", "サイズ") ' サイズ取得
            Call SanitizeXMLMarkNode(MarkNode, WorkSheetName, ".//text[@column!='']", "ラベル") ' ラベル取得
            Call SanitizeXMLMarkNode(MarkNode, WorkSheetName, ".//lod[@column!='']", "詳細")  ' 詳細取得
            Call SanitizeXMLMarkNode(MarkNode, WorkSheetName, ".//wedge-size[@column!='']", "角度") ' 角度取得
            Call SanitizeXMLMarkNode(MarkNode, WorkSheetName, ".//tooltip[@column!='']", "ツールヒント") ' ツールヒント取得
        Next MarkNode
        
        ' 行
        For Each MarkNode In WorkSheetNode.SelectNodes(".//table/rows")
            Call SanitizeXMLMarkNodeMatlix(MarkNode, WorkSheetName, "行")
        Next MarkNode
        ' 列
        For Each MarkNode In WorkSheetNode.SelectNodes(".//table/cols")
            Call SanitizeXMLMarkNodeMatlix(MarkNode, WorkSheetName, "列")
        Next MarkNode
        
    Next WorkSheetNode
End Sub

Private Sub SanitizeXMLMarkNode(ByVal MarkNode As IXMLDOMElement, ByVal WorkSheetName As String, ByVal Xpath As String, ByVal ColumnType As String)
    
    Dim Node As IXMLDOMElement
    Dim WorkSheetFieldId As String               ' name属性
    Dim FieldDataSouce As String               ' name属性
    Dim WorkSheetField As WorkSheetFieldClass
    Dim FieldCaption As String
    
    For Each Node In MarkNode.SelectNodes(Xpath) ' ラベル取得
        WorkSheetFieldId = Node.getAttribute("column")
        
        If WorkSheetName <> "" And WorkSheetFieldId <> "" Then ' クラス格納
            
            Set WorkSheetField = New WorkSheetFieldClass
            
            WorkSheetFieldId = "[" & WorkSheetName & "]." & WorkSheetFieldId & ".[" & ColumnType & "]" ' [0.ワークシート].[1.データソース].[2.フィールド名].[3.フィールドタイプ]の形式
            
            FieldCaption = "[" & Regexp_Execute(WorkSheetFieldId, "\[.+\]\.\[(.+)\].\[.+\].\[.+\]") & "].[" & SanitizeStrings(WorkSheetFieldId) & "]"
            WorkSheetField.WorkSheetName = WorkSheetName
            WorkSheetField.WorkSheetFieldId = WorkSheetFieldId
            WorkSheetField.FieldType = ColumnType
            WorkSheetField.FieldCaption = FieldCaption
            WorkSheetField.FieldDataSouce = Regexp_Execute(WorkSheetFieldId, "\[.+\]\.\[(.+)\].\[.+\].\[.+\]")
            
            If WorkSheetFields.Exists(WorkSheetFieldId) = False Then
                WorkSheetFields.Add WorkSheetFieldId, WorkSheetField
            End If
        End If
    Next Node
End Sub



' 文字列を成形して抽出する
Private Function SanitizeStrings(ByVal str As String) As String
    str = Regexp_Execute(str, "\[.+\]\.\[.+\].\[(.+)\].\[.+\]")
    Select Case UBound(Split(str, ":"))
       Case 0
            SanitizeStrings = str
       Case 1
           SanitizeStrings = Split(str, ":")(1)
       Case 2
           SanitizeStrings = Split(str, ":")(1)
       Case 3
           SanitizeStrings = Split(str, ":")(2)
       Case 4
           SanitizeStrings = Split(str, ":")(2)
   End Select
End Function


' メジャーネーム
Private Sub SanitizeXMLMarkNodeFilterValue(ByVal MarkNode As IXMLDOMElement, ByVal WorkSheetName As String, ByVal Xpath As String, ByVal ColumnType As String)
    
    Dim Node As IXMLDOMElement
    Dim WorkSheetFieldId As String               ' name属性
    Dim FieldDataSouce As String               ' name属性
    Dim WorkSheetField As WorkSheetFieldClass
    Dim FieldCaption As String
    
    For Each Node In MarkNode.SelectNodes(Xpath) ' ラベル取得
        WorkSheetFieldId = Node.getAttribute("member")
        
        If WorkSheetName <> "" And WorkSheetFieldId <> "" Then ' クラス格納
            
            Set WorkSheetField = New WorkSheetFieldClass
            
            WorkSheetFieldId = Replace(WorkSheetFieldId, """", "")
            WorkSheetFieldId = "[" & WorkSheetName & "]." & WorkSheetFieldId & ".[" & ColumnType & "]" ' [0.ワークシート].[1.データソース].[2.フィールド名].[3.フィールドタイプ]の形式
            
            FieldCaption = "[" & Regexp_Execute(WorkSheetFieldId, "\[.+\]\.\[(.+)\].\[.+\].\[.+\]") & "].[" & SanitizeStrings(WorkSheetFieldId) & "]"
            WorkSheetField.WorkSheetName = WorkSheetName
            WorkSheetField.WorkSheetFieldId = WorkSheetFieldId
            WorkSheetField.FieldType = ColumnType
            WorkSheetField.FieldCaption = getFieldCaption(FieldCaption)
            WorkSheetField.FieldDataSouce = Regexp_Execute(WorkSheetFieldId, "\[.+\]\.\[(.+)\].\[.+\].\[.+\]")
            
            If WorkSheetFields.Exists(WorkSheetFieldId) = False Then
                WorkSheetFields.Add WorkSheetFieldId, WorkSheetField
            End If
        End If
    Next Node
End Sub


' 行列
Private Sub SanitizeXMLMarkNodeMatlix(ByVal MarkNode As IXMLDOMElement, ByVal WorkSheetName As String, ByVal ColumnType As String)
    
    Dim Node As IXMLDOMElement
    Dim WorkSheetFieldKey As Variant               ' name属性
    Dim FieldIdList As String               ' name属性
    Dim FieldDataSouce As String               ' name属性
    Dim WorkSheetField As WorkSheetFieldClass
    Dim FieldName As Variant
    Dim FieldCaption As String
    Dim WorkSheetFieldId As String
    
    Dim re
    Dim mc As MatchCollection
    
    Set re = CreateObject("VBScript.RegExp")

    ' 正規表現パターンをセット
    re.Pattern = "(\[.+\]\.\[.+\])"
    re.Global = True
    
    ' 成形（すごいだるい）
    FieldIdList = Replace(Replace(MarkNode.Text, "[pcdf:", "["), "[win:", "[")
    FieldIdList = Replace(Replace(FieldIdList, "[avg:", "["), "[none:", "[")
    FieldIdList = Replace(Replace(FieldIdList, "[sum:", "["), "[tqr:", "[")
    FieldIdList = Replace(Replace(Replace(FieldIdList, "[usr:", "["), "[cum:", "["), "[mn:", "[")
    FieldIdList = Replace(Replace(Replace(FieldIdList, ":nk]", "]"), ":ok]", "]"), ":qk]", "]")
    
    FieldIdList = Replace(Replace(Replace(FieldIdList, ":3]", "]"), ":2]", "]"), ":1]", "]")
    FieldIdList = Replace(Replace(Replace(FieldIdList, ":6]", "]"), ":5]", "]"), ":4]", "]")
    FieldIdList = Replace(Replace(Replace(FieldIdList, ":9]", "]"), ":8]", "]"), ":7]", "]")
    
    For Each WorkSheetFieldKey In re.Execute(FieldIdList)
        WorkSheetFieldId = WorkSheetFieldKey.SubMatches(0)

        If WorkSheetName <> "" And WorkSheetFieldId <> "" Then ' クラス格納
            Set WorkSheetField = New WorkSheetFieldClass
            
            WorkSheetFieldId = Replace(WorkSheetFieldId, """", "")
            
            ' aaaa
            For Each FieldName In Fields
                If InStr(WorkSheetFieldId, FieldName) > 0 Then
                    FieldName = "[" & WorkSheetName & "]." & FieldName & ".[" & ColumnType & "]" ' [0.ワークシート].[1.データソース].[2.フィールド名].[3.フィールドタイプ]の形式
                    FieldCaption = "[" & Regexp_Execute(FieldName, "\[.+\]\.\[(.+)\].\[.+\].\[.+\]") & "].[" & SanitizeStrings(FieldName) & "]"
            
                    WorkSheetField.WorkSheetName = WorkSheetName
                    WorkSheetField.WorkSheetFieldId = FieldName
                    WorkSheetField.FieldType = ColumnType
                    WorkSheetField.FieldCaption = FieldCaption
                    WorkSheetField.FieldDataSouce = Regexp_Execute(FieldName, "\[.+\]\.\[(.+)\].\[.+\].\[.+\]")
            
                    If WorkSheetFields.Exists(WorkSheetFieldId) = False Then
                        WorkSheetFields.Add FieldName, WorkSheetField
                    End If
                End If
            Next FieldName
        End If
    Next WorkSheetFieldKey
End Sub



Private Sub getFields()
    Const ROW_FormulaStart As Long = 2
    Const SHEET1 As String = "フィールド"
    Dim WS As Worksheet
    Dim R, i As Long
    Dim Field As FieldClass
    Dim Id As String
    Set WS = ThisWorkbook.Worksheets(SHEET1)
    Set Fields = New Dictionary
        
    ' データ取得　と　データ登録
    R = WS.UsedRange.Rows.Count
    If R >= ROW_FormulaStart Then
        For i = ROW_FormulaStart To R
            ' クラス格納
            Set Field = New FieldClass
            Id = WS.Cells(i, 1).Value
            Field.Id = Id
            Field.FieldCaption = WS.Cells(i, 4).Value
            Fields.Add Id, Field
        Next i
    End If
End Sub

Private Sub getDataSouces()
    Const ROW_FormulaStart As Long = 2
    Const SHEET1 As String = "データソース"
    Dim WS As Worksheet
    Dim R, i As Long
    Dim Field As FieldClass
    Dim Id, DataSourceId, DataSource As String
    Set WS = ThisWorkbook.Worksheets(SHEET1)
    Set DataSources = New Dictionary
        
    ' データ取得　と　データ登録
    R = WS.UsedRange.Rows.Count
    If R >= ROW_FormulaStart Then
        For i = ROW_FormulaStart To R
            ' クラス格納
            DataSourceId = WS.Cells(i, 1).Value
            DataSource = WS.Cells(i, 2).Value
            DataSources.Add DataSourceId, DataSource
        Next i
    End If
End Sub


        

' フィールドをExcelへ出力
Private Sub PrintFieldsData()
    
    Const TARGET_SHEET As String = "ワークシートフィールド" ' 出力先シートを指定
    Dim WS As Worksheet
    Dim Row As Long: Row = 2
    Dim DataSourceKey As Variant
    Dim WorkSheetFieldKey As Variant
    Dim FieldFormula As String
    Dim WorkSheetField As WorkSheetFieldClass
    
    Set WS = ThisWorkbook.Worksheets(TARGET_SHEET)
    
    ' datasourceごとに順次処理
    For Each WorkSheetFieldKey In WorkSheetFields.Keys
        Set WorkSheetField = WorkSheetFields.Item(WorkSheetFieldKey)
                
        ' 出力
        WS.Cells(Row, 1) = WorkSheetField.WorkSheetFieldId
        WS.Cells(Row, 2) = WorkSheetField.WorkSheetName
        WS.Cells(Row, 3) = WorkSheetField.FieldDataSouce
        WS.Cells(Row, 4) = getFieldCaption(WorkSheetField.FieldCaption)
        WS.Cells(Row, 5) = WorkSheetField.FieldType

        Row = Row + 1
    Next WorkSheetFieldKey
End Sub


' 計算フィールドの内部の置換する
Private Function getFieldCaption(ByVal FieldFormula_primary As String) As String
    Dim X As Variant
    Dim X2 As Variant
    Dim T As Variant
    Dim FieldFormula As Variant
    Dim A As Dictionary
    Dim FieldCaption, Q As String
    
    FieldFormula = FieldFormula_primary
    
    Q = FieldFormula
    
    For Each X In Fields.Keys
        If FieldFormula = Fields.Item(X).Id Then
            FieldCaption = Fields.Item(X).FieldCaption
            Q = Fields.Item(X).FieldCaption
            Exit For
        End If
    Next X
    getFieldCaption = Q
End Function

処理_006フィールド参照関係

計算フィールド内で参照しているフェールドを取得します。
現状は、親と子の関係をリストしますが、将来的に家系図をネットワーク構造で表示できるようにします。

' Option Explicit

Sub 処理_参照関係()
    
    Dim FSO As FileSystemObject
    Dim FilePath As String
    Dim TempFolder As String
    Dim TWBFilePath As String
    Dim File As File
    Const ROW_FormulaStart As Long = 2
    Const SHEET1 As String = "フィールド"
    Const Sheet2 As String = "参照関係"
    
    Dim DOM As DOMDocument60
    Dim XML As IXMLDOMElement
    Dim Node As IXMLDOMElement
    
    Dim V As Variant
    
    Set WS = ThisWorkbook.Worksheets(SHEET1)
    Set WS2 = ThisWorkbook.Worksheets(Sheet2)
    
    ' 出力先のデータを削除する
    r2 = WS2.UsedRange.Rows.Count
    If r2 >= ROW_FormulaStart Then
        WS2.Range(WS2.Rows(ROW_FormulaStart), WS2.Rows(r2)).ClearContents
    End If
    
    ' データ取得　と　データ登録
    R = WS.UsedRange.Rows.Count
    If R >= ROW_FormulaStart Then
        k = ROW_FormulaStart
        For i = ROW_FormulaStart To R
            For j = ROW_FormulaStart To R
                If InStr(WS.Cells(i, 5).Value, "[" & WS.Cells(j, 4).Value & "]") > 0 _
                    And WS.Cells(j, 2).Value = WS.Cells(i, 2).Value Then ' データソースが一致
                        WS2.Cells(k, 1) = WS.Cells(i, 2).Value
                        WS2.Cells(k, 2) = WS.Cells(i, 4).Value
                        WS2.Cells(k, 3) = WS.Cells(j, 4).Value
                    k = k + 1
                End If
            Next j
        Next i
    End If
End Sub

２．クラスモジュール

FieldClass

フィールドリストを作る際に使用するクラスです。

Public Id As String
Public FieldId As String
Public FieldCaption As String
Public DataSource As String
Public FieldFormula As String
Public FieldRole As String
Public FieldDataType As String

WorkSheetFieldClass

ワークシートフィールドリストを作る際に使用するクラスです。

Public WorkSheetName As String
Public WorkSheetFieldId As String
Public FieldCaption As String
Public FieldType As String
Public FieldDataSouce As String

３．画面

今回使用したtableau ダッシュボードの例（無許可で、すみません。。）
めちゃめちゃかっこいいダッシュボードです！
あとで自分のものに変更します。。。
https://public.tableau.com/app/profile/kajalkadam/viz/V2_1_KPITracking/KPIDashboard

3.1ファイル指定

image.png

3.2フィールドリスト

image.png

3.3参照

image.png

ID 原因 対処法 対処法
1 オブジェクト参照エラー
IXMLDOMElement ライブラリを追加 移動　　：開発タブ>Visual Basic　　・メニューバー>ツール>参照設定
チェック：Microsoft XML, v6.0　　・Microsoft HTML Object Library
2 オブジェクト参照エラー
FileSystemObject ライブラリを追加 移動　　：開発タブ>Visual Basic　　・メニューバー>ツール>参照設定
チェック：Microsoft Scripting Runtime
3 オブジェクト参照エラー
IWshRuntimeLibrary.WshShell ライブラリを追加 移動　　：開発タブ>Visual Basic　　・メニューバー>ツール>参照設定
チェック：Windows Script Host Object Model
1
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?