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