DebugModule.bas

Option Explicit
Private Indent          As Integer
Private Prefix          As String
Private FH              As Object
Private FlagNotime          As Boolean
Private FlagDebugPrint  As Boolean

Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Sub DebugPrint(ByVal VarName As Variant, Optional ByVal Filename As String = "Debug.txt", _
               Optional ByVal TypeNameFlag As Boolean = False, Optional ByVal IndentCount As Integer = 4, _
               Optional NotimeFlag As Boolean = False, Optional DebugPrintFlag As Boolean = False)
    '必須：
    'VarName: データ構造を知りたい変数名を指定
    
    'オプション：
    'Indentcount: 配列、コレクション、Dictionaryなどネストして表示されるデータの全角スペースの数
    'TypeNameFlag:全ての型を表示したい時にTrue
    '----------------------------------------------------------------------------------------------
    
    '再帰呼出で、トップの時⇒追記状態でファイルオープンしておく
    If Indent = 0 Then
        FlagNotime = NotimeFlag
        FlagDebugPrint = DebugPrintFlag
        If Not FlagDebugPrint Then Call FileOpen(Filename)
    End If
    
    
    Dim i As Long
    Dim key As Variant
    If TypeName(VarName) = "Byte" Or TypeName(VarName) = "Integer" Or _
       TypeName(VarName) = "Long" Or TypeName(VarName) = "String" Or _
       TypeName(VarName) = "Single" Or TypeName(VarName) = "Double" Or _
       TypeName(VarName) = "Currency" Or TypeName(VarName) = "Date" Or _
       TypeName(VarName) = "Boolean" Or TypeName(VarName) = "Boolean" Then
        
        Call Output(TypeName(VarName), IndentCount, TypeNameFlag, VarName)

    ElseIf TypeName(VarName) = "Empty" Or TypeName(VarName) = "Null" Or _
           TypeName(VarName) = "Nothing" Or TypeName(VarName) = "Unknown" Then
        
        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
    ElseIf 0 < InStr(TypeName(VarName), "()") Then
        '2次元配列まで対応！3次元以上はNG!
        Dim temp As Integer, Dimension As Integer
        On Error Resume Next
        temp = UBound(VarName, 3)
        If Err.Number = 0 Then
            MsgBox "配列は3次元配列以上は未対応です"
            End
        End If
        
        Err.Clear
        temp = UBound(VarName, 2)
        Dimension = IIf(Err.Number = 0, 2, 1)
        On Error GoTo 0
        
        
        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
        '1次元配列か2次元配列かで処理を分岐
        Indent = Indent + 1
        If Dimension = 1 Then
        '1次元配列の処理
            For i = 0 To UBound(VarName)
                Prefix = "(" & i & "): "
                Call DebugPrint(VarName(i), IndentCount, TypeNameFlag)
            Next
            
        ElseIf Dimension = 2 Then
        '2次元配列の処理
            Dim ii As Long
            For i = 0 To UBound(VarName, 1)
                For ii = 0 To UBound(VarName, 2)
                    Prefix = "(" & i & "," & ii & "): "
                    Call DebugPrint(VarName(i, ii), IndentCount, TypeNameFlag)
                Next
            Next
        End If
        Indent = Indent - 1
    ElseIf TypeName(VarName) = "Collection" Then

        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
        Indent = Indent + 1
        For i = 1 To VarName.Count
            Prefix = i & ":"
            Call DebugPrint(VarName.Item(i), IndentCount, TypeNameFlag)
        Next
        Indent = Indent - 1
    
    ElseIf TypeName(VarName) = "Dictionary" Then

        Call Output(TypeName(VarName), IndentCount, TypeNameFlag)
        
        Indent = Indent + 1
        For Each key In VarName
            Prefix = "[" & TypeName(key) & "]" & key & " => "
            Call DebugPrint(VarName.Item(key), IndentCount, TypeNameFlag)
        Next
        Indent = Indent - 1
        
    End If
     
    '再帰呼出で、トップの時⇒追記状態でファイルオープンしておく
    If Indent = 0 And Not FlagDebugPrint Then Call FileClose
End Sub

Sub Output(ByVal TypeVarName As String, ByVal IndentCount As Integer, ByVal TypeNameFlag As Boolean, Optional ByVal VarName As Variant = "")
    If IndentCount < 0 Then IndentCount = 0
    
    Dim OutPutData As String
    If TypeNameFlag Then
        OutPutData = String(Indent * IndentCount, " ") & Prefix & "[" & TypeVarName & "]" & VarName & vbCrLf
            
        If FlagDebugPrint Then
            Debug.Print Replace(OutPutData, vbCrLf, "") '改行ははずす
        Else
            FH.Write OutPutData
        End If
    Else
        If 0 < InStrRev(Prefix, "]") Then
            Prefix = Right(Prefix, Len(Prefix) - InStrRev(Prefix, "]"))
        End If
        
        If 0 < InStr(TypeVarName, "()") Or TypeVarName = "Collection" Or TypeVarName = "Dictionary" Then
            OutPutData = String(Indent * IndentCount, " ") & Prefix & "[" & TypeVarName & "]" & VarName & vbCrLf
            
            If FlagDebugPrint Then
                Debug.Print Replace(OutPutData, vbCrLf, "") '改行ははずす
            Else
                FH.Write OutPutData
            End If
        Else
            OutPutData = String(Indent * IndentCount, " ") & Prefix & VarName & vbCrLf
            
            If FlagDebugPrint Then
                Debug.Print Replace(OutPutData, vbCrLf, "") '改行ははずす
            Else
                FH.Write OutPutData
            End If
        End If
    End If
    
    Prefix = ""
End Sub


Private Sub FileOpen(ByVal Filename As String)
    '.txtが省略されていたら追加する
    If 0 = InStr(Filename, ".txt") Then Filename = Filename & ".txt"
    
    Dim FSO As Object, FilePath As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    

    If FlagNotime Then
        FilePath = ThisWorkbook.Path & "\" & Filename
        Set FH = FSO.OPenTextFile(FilePath, 2, True)
    Else
        FilePath = ThisWorkbook.Path & "\(" & Replace(Time, ":", "") & ")" & Filename
        Set FH = FSO.OPenTextFile(FilePath, 8, True)
    End If
    
    Set FSO = Nothing
End Sub

Private Sub FileClose()
    FH.Close
    Set FH = Nothing
    
    Sleep (1000) '同名ファイルに出力されるのを避けるため、１秒時間をおいている
End Sub


'■SampleCode
Private Sub SampleCode1()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    '■配列データの出力を行います
    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    '※引数にデータ構造を見たい変数名を指定します
    '実行Excelファイルと同階層に (時間)Debug.txt として出力されます
    Call DebugPrint(varArray)
    '-----------------------------
    '[Variant()]
    '　　(0): 文字列
    '　　(1): 3
    '　　(2): True
    '-----------------------------
End Sub

Private Sub SampleCode2()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    '■Dictionaryの出力を行います
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    '※引数にデータ構造を見たい変数名を指定します
    '実行Excelファイルと同階層に (時間)Debug.txt として出力されます
    Call DebugPrint(varDic)
    '-----------------------------
    '※ファイルの出力結果
    '[Dictionary]
    '配列1 => [Variant()]
    '　　(0): 文字列
    '　　(1): 3
    '　　(2): True
    '配列2 => [Variant()]
    '　　(0): a
    '　　(1): b
    '　　(2): c
    '-----------------------------
    
    '対応している変数形式は
    'String/Integer/Long/Single/Double/Currency/Date/Boolean/Byte/Variant
    '上記を用いた、Collection/Dictionary/配列(2次元配列まで)
End Sub

Private Sub SampleCode3()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■複数出力したとき、何の変数を出力したものか判断がつきにくい！
    '　なんとかしてほしい
    '　⇒Filenameオプションにファイル名を指定してください
    Call DebugPrint(varArray, Filename:="Array.txt")
    Call DebugPrint(varDic, Filename:="Dictionary") '拡張子は書かなくても自動的.txtになります
End Sub


Private Sub SampleCode4()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■複数出力なんてしません！なのでファイル名に時間をつけて複数出力するのはやめてくれますか？
    '　何度も何度も消すのがめんどくさい。ゴミ箱がひどいことになる・・・
    '　⇒NotimeFlagオプションをTrueにしてください
    Call DebugPrint(varDic, Filename:="上書きテスト")
    Call DebugPrint(varDic, Filename:="上書きテスト") '通常だと(時間)上書きテスト.txt が時間ごとに作られる
    Call DebugPrint(varDic, Filename:="上書きテスト", NotimeFlag:=True)
    Call DebugPrint(varDic, Filename:="上書きテスト", NotimeFlag:=True)
    Call DebugPrint(varDic, Filename:="上書きテスト", NotimeFlag:=True) '上書きテスト.txt が一つだけ作られる(一番最後に実行したものだけが残る)
End Sub

Private Sub SampleCode5()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    'Q And A
    '■配列/Collection/Dictionaryでインデントされて出力
    '　されますが、あの幅が好みじゃない・・・。
    '　⇒IndentCountオプションを指定してください
    Call DebugPrint(varDic, IndentCount:=5)
    
    '-----------------------------
    '※ファイルの出力結果
    '[Dictionary]
    '　　　　　配列1 => [Variant()]
    '　　　　　　　　　　(0): 文字列
    '　　　　　　　　　　(1): 3
    '　　　　　　　　　　(2): True
    '　　　　　配列2 => [Variant()]
    '　　　　　　　　　　(0): a
    '　　　　　　　　　　(1): b
    '　　　　　　　　　　(2): c
    '-----------------------------
End Sub

Private Sub SampleCode6()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■データの型式を全てみたいです
    '　⇒TypeNameFlagオプションをTrueにしてください
    Call DebugPrint(varDic, TypeNameFlag:=True)
    
    '-----------------------------
    '※ファイルの出力結果
    '[Dictionary]
    '[String] 配列1 >= [Variant()]
    '　　(0): [String]文字列
    '　　(1): [Integer]3
    '　　(2): [Boolean]True
    '[String] 配列2 >= [Variant()]
    '　　(0): [String]a
    '　　(1): [String]b
    '　　(2): [String]c
    '-----------------------------
End Sub

Private Sub SampleCode7()
    'Dummyデータ
    Dim varString   As String:   varString = "文字列"
    Dim varInteger  As Integer:  varInteger = 3
    Dim varLong     As Long:     varLong = 3
    Dim varDouble   As Double:   varDouble = 3.5
    Dim varBoolean  As Boolean:  varBoolean = True

    Dim varArray(2) As Variant
        varArray(0) = varString
        varArray(1) = varInteger
        varArray(2) = varBoolean
    
    Dim varDic As Object
    Set varDic = CreateObject("Scripting.Dictionary")
    varDic.Add "配列1", varArray
    varDic.Add "配列2", Array("a", "b", "c")
    
    
    'Q And A
    '■ファイルじゃなくイミディエイトウィンドウにだしてよ
    '　⇒DebugPrintFlagをTrueにしてください
    Call DebugPrint(varDic, DebugPrintFlag:=True)
    
End Sub

xmlObj.cls

Option Explicit

Dim xmlObj      As Object
Dim xmlAttr     As Object
Dim xmlNode     As Object
Dim xmlString   As String

Private Sub Class_Initialize()

    Set xmlObj = CreateObject("MSXML2.DOMDocument")
    xmlObj.async = False
    xmlObj.setProperty "SelectionLanguage", "XPath"
    
    xmlObj.appendChild xmlObj.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
End Sub

Private Sub Class_Terminate()
    Set xmlObj = Nothing
End Sub

Public Sub XMLin(ByVal data As Variant)
    
    If TypeName(data) = "String" Then
        Call FileLoad(data)
        
    ElseIf TypeName(data) = "Dictionary" Then
        Call judgeTypeName(data)
        
    Else
        Call Die("XMLinメソッドは、String型またはDictionary型のみを取ることができます" & vbCrLf & _
                 "引数の型：" & TypeName(data))
    End If
    
End Sub

Public Sub XMLout(ByVal FilePath As String)
    xmlObj.Save FilePath
End Sub

Public Function XPath(ByVal strXPath As String)
    
    'xmlの文字列をロードする
    xmlObj.loadXML xmlString
    
    Set XPath = xmlObj.documentElement.selectNodes(strXPath)
    
End Function


Private Sub FileLoad(ByVal FilePath As Variant)
    
    Dim FH  As Object
    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    xmlString = ""
    
    If Not FSO.FileExists(FilePath) Then Call Die("FileLoadメソッド：ファイルは存在しません" & vbCrLf & "FilePath:" & FilePath)
    
    Set FH = FSO.OPenTextFile(FilePath, 1)
    
    Do While Not FH.AtEndOfStream
        xmlString = xmlString & FH.ReadLine
    
    Loop
    
    FH.Close
    
    Set FH = Nothing
    Set FSO = Nothing
    
End Sub

Private Sub judgeTypeName(ByRef data As Variant)
    
    Dim counter As Long
    Dim key     As Variant
    
    'キーに属性を含んでいる場合を高所して先に属性の登録を行う
    Call AddAttributeNode(data)
    
    
    For Each key In data
        counter = counter + 1
        
        If AddXmlNode(key) Then GoTo NextForLoop

        
        If TypeName(key) = "Dictionary" Then
            Call judgeTypeName(key)
            If counter = data.Count Then _
                Set xmlNode = xmlNode.parentNode
            
        ElseIf TypeName(data(key)) = "Collection" Then
            Call judgeTypeName(data(key))
                
        ElseIf TypeName(data(key)) = "Dictionary" Then
            Call judgeTypeName(data(key))
            
            If counter = data.Count Then _
                Set xmlNode = xmlNode.parentNode
            
        ElseIf TypeName(data(key)) = "String" Then
            Call AddChildText(data(key))
        
        Else
            Call Die("judgeTypeNameメソッドエラー：")
            Debug.Print ""
        
        End If
        
NextForLoop:
    Next
    
End Sub

Private Sub AddChildText(ByVal ChildText As String)
    '子要素にテキストを追加
    Set xmlNode = xmlNode.appendChild(xmlObj.createTextNode(ChildText))
    Set xmlNode = xmlNode.parentNode
    Set xmlNode = xmlNode.parentNode
    
End Sub


Private Sub AddAttributeNode(ByRef data As Variant)
    
    Dim key As Variant
    
    '子要素をぶら下げた後に属性処理をすると意図したところと違うところに属性がつくので
    '最初にキーを走査して属性を探しあれば親要素に属性を追加する
    For Each key In data
    
        If TypeName(key) <> "String" Then GoTo NextForEach
        If key = "@" Then
            Call Die("AddAttributeNodeメソッドエラー：属性名がありません")
            
        ElseIf Left(key, 1) = "@" Then
            Set xmlAttr = xmlNode.Attributes.setNamedItem(xmlObj.createAttribute(Mid(key, 2, Len(key))))
            xmlAttr.nodeValue = data(key)
        End If

NextForEach:
    Next
    
End Sub

Private Function AddXmlNode(ByRef key As Variant)
    
    If TypeName(key) <> "String" Then
        Exit Function
    
    ElseIf key = "" Then
        Exit Function
    
    End If
    
    
    'キーを処理する
    If xmlNode Is Nothing Then
    'Nothingの時は初なのでルートとして指定
        Set xmlNode = xmlObj.appendChild(xmlObj.CreateElement(key))
    
    Else
    '親要素以外の処理
        If Left(key, 1) <> "@" Then
        '@で始まらない時は、子要素として登録。 False(0)を返す
            Set xmlNode = xmlNode.appendChild(xmlObj.CreateElement(key))
            AddXmlNode = 0
            
       Else
       '@で始まる時は、True(1)を返す
            AddXmlNode = 1
       
       End If
       
    End If
    
End Function

Private Sub Die(ByVal msg As String)
    MsgBox "下記理由により終了します" & vbCrLf & _
           msg
    End
End Sub

Logger

Option Explicit

Dim data()              As String
Dim DataCellObj         As Object
Dim DataSheetObj        As Object
Dim x                   As Long
Dim y                   As Long
Dim DelColumn           As Long
Dim FlagTransposeError  As Boolean

'Setter/Getter
Public Property Let DeleteColumn(ByVal Num As Long)
DelColumn = Num
End Property

Public Property Get DeleteColumn() As Long
DeleteColumn = DelColumn
End Property


Private Sub Class_Initialize()

'初期化
x = -1
y = -1

End Sub

Public Sub BorderLine(Optional ByVal Sht As Worksheet, Optional ByVal Cell As String, _
Optional ByVal LineStyle As Integer = xlContinuous, _
Optional Weight As Integer = xlThin, _
Optional ColorIndex As Integer = xlAutomatic)

Dim BaseRow     As Long
Dim BaseCol     As Long
Dim RangeObj    As Object

If Not Sht Is Nothing Then Set DataSheetObj = Sht
If DataCellObj Is Nothing Then Call Die("Sheetobjが設定されていません")

If Cell <> "" Then Set DataCellObj = DataSheetObj.Range(Cell)
If DataCellObj Is Nothing Then Call Die("開始のセル情報がありません")

'初期値のままだと出力できないので終了する
If y < 0 Then Exit Sub
    
    BaseRow = DataCellObj.Row
    BaseCol = DataCellObj.Column
    
    Set RangeObj = DataSheetObj.Range(DataSheetObj.Cells(BaseRow, BaseCol), DataSheetObj.Cells(BaseRow + y, BaseCol + x))
    
    RangeObj.Borders(xlEdgeLeft).LineStyle = LineStyle
    RangeObj.Borders(xlEdgeLeft).Weight = Weight
    RangeObj.Borders(xlEdgeLeft).ColorIndex = ColorIndex

    RangeObj.Borders(xlEdgeTop).LineStyle = LineStyle
    RangeObj.Borders(xlEdgeTop).Weight = Weight
    RangeObj.Borders(xlEdgeTop).ColorIndex = ColorIndex
    
    RangeObj.Borders(xlEdgeBottom).LineStyle = LineStyle
    RangeObj.Borders(xlEdgeBottom).Weight = Weight
    RangeObj.Borders(xlEdgeBottom).ColorIndex = ColorIndex
    
    RangeObj.Borders(xlEdgeRight).LineStyle = LineStyle
    RangeObj.Borders(xlEdgeRight).Weight = Weight
    RangeObj.Borders(xlEdgeRight).ColorIndex = ColorIndex
    
    If 0 < x Then
        RangeObj.Borders(xlInsideVertical).LineStyle = LineStyle
        RangeObj.Borders(xlInsideVertical).Weight = Weight
        RangeObj.Borders(xlInsideVertical).ColorIndex = ColorIndex
    End If
    
    If 0 < y Then
        RangeObj.Borders(xlInsideHorizontal).LineStyle = LineStyle
        RangeObj.Borders(xlInsideHorizontal).Weight = Weight
        RangeObj.Borders(xlInsideHorizontal).ColorIndex = ColorIndex
    End If

End Sub

Public Function Count()
    
    If x = -1 And y = -1 Then
    
        Count = 0
    
    Else
    
        '要素数を返す
        Count = UBound(data, 2) + 1

    End If
End Function

Public Function Item(ByVal a As Long, ByVal B As Long, Optional ByVal Str As Variant)

    '引数なし
    If IsMissing(Str) Then
    
        Item = data(a, B)
        
    '引数あり
    Else
    
        data(a, B) = Str
    
    End If

End Function

Public Function Join(ByVal Ele02 As Long, ByVal delimiter As String)
    Dim i    As Long
    Dim temp As String
    
    For i = 0 To UBound(data, 1)
        temp = temp & data(i, Ele02) & IIf(i = UBound(data, 1), "", delimiter)
    Next

    Join = temp
End Function

Public Function Last()

    '最終要素を返す
    Last = UBound(data, 2)

End Function

Private Function TransposeData()
    Dim S        As Long
    Dim t        As Long
    Dim TPData() As String
    ReDim TPData(y, x)
    
    For S = 0 To y
        For t = 0 To x
            TPData(S, t) = data(t, S)
        Next
    Next
    
    TransposeData = TPData
End Function

Public Function Value() As String()

    '２次元配列自体を返す
    Value = data()

End Function

Public Sub Add(ByRef list As Variant)
    Dim i As Long
    
    '１次元の要素数が確定していない時、要素数の調査をおこなう
    If x = -1 Then
        
        If TypeName(list) = "Variant()" Or TypeName(list) = "String()" Then
            
            x = UBound(list)
        
        Else
            
            x = 0
        
        End If
    
    End If
    
    
    '要素数の再定義
    y = y + 1
    ReDim Preserve data(x, y)
    
    If TypeName(list) = "Variant()" Or TypeName(list) = "String()" Then
        
        For i = 0 To x
        
            '要素数が足りないときは、空文字を指定
            On Error Resume Next
            
            data(i, y) = list(i)
            
            'Transpose関数は255文字を越えたデータを受け取るとエラーとなるので判定する
            If 255 < Len(list(i)) Then FlagTransposeError = True
            
            On Error GoTo 0
        
        Next
        
    Else
    
        data(x, y) = list
    
        'Transpose関数は255文字を越えたデータを受け取るとエラーとなるので判定する
        If 255 < Len(list) Then FlagTransposeError = True
    
    End If

End Sub

Public Sub Clear()
    
    '初期化
    Erase data
    
    DelColumn = -1
    
    x = -1
    y = -1
    
    FlagTransposeError = False

End Sub

Private Sub Die(ByVal msg As String)
    
    MsgBox "下記理由により終了します" & vbCrLf & msg
    End

End Sub

Public Function Output(ByVal Sht As Worksheet, ByVal Cell As String, Optional ByVal KeyIndexNumber As Long = -1)
    Dim BaseRow As Long
    Dim BaseCol As Long
    
    'JuuFukuチェック用の引数が指定されていたらチェックする
    If -1 < KeyIndexNumber Then
        
        Call OverLapCheck(KeyIndexNumber)
                     
    End If
    
    BaseRow = Sht.Range(Cell).Row
    BaseCol = Sht.Range(Cell).Column
    
    'DelColumnが1以上でセットされている時該当列をクリアする
    If 0 < DelColumn Then
        Sht.Range(Sht.Cells(BaseRow, BaseCol), Sht.Cells(65536, BaseCol + DelColumn)).ClearContents
    End If
    
    
    '初期値のままだと出力できないので終了する
    If y < 0 Then Exit Function
    
    If FlagTransposeError Then
        
        Sht.Range(Sht.Cells(BaseRow, BaseCol), Sht.Cells(BaseRow + y, BaseCol + x)) = TransposeData()
    
    Else
    
        Sht.Range(Sht.Cells(BaseRow, BaseCol), Sht.Cells(BaseRow + y, BaseCol + x)) = WorksheetFunction.Transpose(data)
    
    End If
    
    Set DataCellObj = Sht.Range(Cell)
    Set DataSheetObj = Sht
    Set Output = Me
    
End Function

Public Sub Sort(Optional ByVal Element As Variant)
    Dim i As Long
    
    '■引数エラーチェック
    
    If VarType(Element) = vbError Then
        '引数が設定されていないと　VarTypeでErrorとなるのでチェックする
        '引数が設定されていない時は、最初の要素についてSortする
        Element = Array(0)

    ElseIf IsNumeric(Element) Then
        '数字の時、整数値か確認。０以上か確認。
        If CLng(Element) <> Element Or Element < 0 Then
            Call Die("Sort関数の引数には、0以上の整数を指定してください")
        
        Else
            Element = Array(CLng(Element))
        End If
    
    ElseIf Not IsArray(Element) Then
        Call Die("Sortメソッドの引数は、配列を指定してください")
    
    End If
    
    '引数がセットされていた時、それらはすべて整数で要素数の範囲内かどうかチェックする
    For i = UBound(Element) To 0 Step -1

        Call BubbleSort(Element(i))
            
    Next
    
End Sub

Private Sub BubbleSort(ByVal Element As Long)
    Dim ChangeData As String
    Dim DataA      As String
    Dim DataB      As String
    Dim FlagChange As String
    Dim i          As Long
    Dim ii         As Long
    
    'データがない時ソートができないので終了する
    If Count = 0 Then Exit Sub
    
    Do
        FlagChange = False
        For i = 0 To UBound(data, 2) - 1
            DataA = data(Element, i)
            DataB = data(Element, i + 1)
            
            If DataB < DataA Then
                FlagChange = True
                
                For ii = 0 To UBound(data, 1)
                    ChangeData = data(ii, i)
                    data(ii, i) = data(ii, i + 1)
                    data(ii, i + 1) = ChangeData
                Next
                
            End If
            
        Next
            
        If FlagChange = False Then Exit Do
    Loop
End Sub

Private Sub OverLapCheck(ByVal KeyIndexNumber As Long)

    Dim HashOverLap As Object
    Dim key         As String
    Dim i           As Long
    Dim ii          As Long
    Dim temp()      As String
    
    '** Objectの生成 **
    Set HashOverLap = CreateObject("Scripting.Dictionary")
    
    'そもそも二次元配列が空の時はループを抜ける
    If y = -1 Then Exit Sub
    
    y = -1
    
    'JuuFukuCheckする
    For i = 0 To UBound(data, 2)
    
        key = data(KeyIndexNumber, i)
        
        If Not HashOverLap.Exists(key) Then
        
            HashOverLap.Add key, ""
            
            y = y + 1
            
            ReDim Preserve temp(UBound(data, 1), y)
            
            For ii = 0 To UBound(data, 1)
            
                temp(ii, y) = data(ii, i)
              
            Next
                
        End If
        
    Next
    
    'Temp内は重複がチェックされたもの。
    'Dataの内容を書き換える
    ReDim data(UBound(temp, 1), UBound(temp, 2))
    
    data = temp
    
    Set HashOverLap = Nothing
End Sub