ライブラリ

fRange_Border_Is田

***************************************************************
指定Rangeに指定罫線が格子状に引かれているか判定

【引数】Range :対象のRange
【引数】Style   :罫線のスタイル
【引数】Color   :罫線の色
【引数】Weight :罫線の太さ
***************************************************************

Option Explicit
Option Private Module

Public Enum E_Borders
    DiagonalDown = 2 ^ 0
    DiagonalUp = 2 ^ 1
    EdgeLeft = 2 ^ 2
    EdgeTop = 2 ^ 3
    EdgeBottom = 2 ^ 4
    EdgeRight = 2 ^ 5
    InsideVertical = 2 ^ 6
    InsideHorizontal = 2 ^ 7
End Enum

Public Function fRange_Border_Is田(Range As Range, _
                                   Optional Style As XlLineStyle = xlContinuous, _
                                   Optional Color As Long = vbBlack, _
                                   Optional Weight As XlBorderWeight = xlThin) As Boolean
    
    Dim Borders As E_Borders
    Borders = E_Borders.EdgeBottom + E_Borders.EdgeLeft + E_Borders.EdgeRight + E_Borders.EdgeTop
    
    'セルアドレス判定用の辞書
    Dim Dic As Scripting.Dictionary
    Set Dic = New Scripting.Dictionary
    
    Dim Cell As Range
    For Each Cell In Range.Cells
        
        '結合セルを取得
        Dim Rng As Range
        Set Rng = Cell.MergeArea
        
        '結合セルのアドレスで初めての場合
        Dim Address As String
        Address = Rng.Address(False, False)
        If Dic.Exists(Address) = False Then
            Dic.Item(Address) = Empty
            
            If fRange_Borders_Exists(Rng, Borders, Style, Color, Weight) = False Then Exit Function
            
        End If
            
    Next
    
    fRange_Border_Is田 = True
    
End Function

Public Function fRange_Borders_Exists(Range As Range, Borders As E_Borders, _
                                      Optional Style As XlLineStyle = xlContinuous, _
                                      Optional Color As Long = -1, _
                                      Optional Weight As XlBorderWeight = 0) As Boolean
    
    With Range
        
        Dim Code   As Variant
        For Each Code In Array(E_Borders.EdgeTop, E_Borders.EdgeLeft, _
                               E_Borders.EdgeRight, E_Borders.EdgeBottom, _
                               E_Borders.InsideHorizontal, E_Borders.InsideVertical, _
                               E_Borders.DiagonalDown, E_Borders.DiagonalUp)
            
            '対象の罫線の場合(※引数で複数選択可)
            If Code And Borders Then
                
                '※結合セルの一部欠けに対応
                Dim Area    As Range
                Set Area = Nothing
                If .Cells.Count > 1 Then
                    Select Case Code
                    Case E_Borders.EdgeTop:     Set Area = .Resize(1)
                    Case E_Borders.EdgeLeft:    Set Area = .Resize(, 1)
                    Case E_Borders.EdgeRight:   Set Area = .Cells(1, .Columns.Count).Resize(.Rows.Count)
                    Case E_Borders.EdgeBottom:  Set Area = .Cells(.Rows.Count, 1).Resize(, .Columns.Count)
                    End Select
                End If
                
                '指定方向を1セルずつ確かめたい場合
                If Area Is Nothing = False Then
                    Dim Cell    As Range
                    For Each Cell In Area.Cells
                        If fRange_Borders_Exists(Cell, CLng(Code), Style, Color, Weight) = False Then Exit Function
                    Next
                Else
                    
                    '各種設定が一致するか判定
                    Dim Index   As XlBordersIndex
                    Index = prBorder_Code_to_Index(CLng(Code))
                    With Range.Borders(Index)
                        
                        '罫線の有無
                        If .LineStyle <> Style Then Exit Function
                        
                        '罫線がある場合
                        If Color >= 0 Then If .Color <> Color Then Exit Function
                        If Weight > 0 Then If .Weight <> Weight Then Exit Function
                        
                    End With
                    
                End If
                
            End If
        Next
        
    End With
    
    fRange_Borders_Exists = True
    
End Function

Private Function prBorder_Code_to_Index(Code As E_Borders) As XlBordersIndex
    
    Dim Index   As XlBordersIndex
    
    Select Case Code
    Case E_Borders.DiagonalDown:        Index = xlDiagonalDown
    Case E_Borders.DiagonalUp:          Index = xlDiagonalUp
    Case E_Borders.EdgeBottom:          Index = xlEdgeBottom
    Case E_Borders.EdgeLeft:            Index = xlEdgeLeft
    Case E_Borders.EdgeRight:           Index = xlEdgeRight
    Case E_Borders.EdgeTop:             Index = xlEdgeTop
    Case E_Borders.InsideHorizontal:    Index = xlInsideHorizontal
    Case E_Borders.InsideVertical:      Index = xlInsideVertical
    End Select
    
    prBorder_Code_to_Index = Index
    
End Function

Border   2018/09/18   shono

この記事へのコメント

コメントを送る

 
※ メールは公開されません
Loading...
 画像の文字を入力してください